ghc-lib 0.20201201 → 0.20210101

raw patch · 120 files changed

+13306/−12360 lines, 120 filesdep ~ghc-lib-parserPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: ghc-lib-parser

API changes (from Hackage documentation)

Files

• compiler/GHC.hs +48/−22
• compiler/GHC/Builtin/Utils.hs +1/−1
• compiler/GHC/ByteCode/Asm.hs +2/−3
• compiler/GHC/ByteCode/Linker.hs +1/−1
• compiler/GHC/Cmm/CommonBlockElim.hs +1/−1
• compiler/GHC/Cmm/LRegSet.hs +53/−0
• compiler/GHC/Cmm/Lexer.x +3/−3
• compiler/GHC/Cmm/Liveness.hs +69/−0
• compiler/GHC/Cmm/Opt.hs +46/−46
• compiler/GHC/Cmm/Parser.y +11/−10
• compiler/GHC/Cmm/Parser/Monad.hs +8/−10
• compiler/GHC/Cmm/Sink.hs +88/−54
• compiler/GHC/Cmm/Utils.hs +5/−3
• compiler/GHC/Core/Map/Expr.hs +392/−0
• compiler/GHC/Core/Opt/CSE.hs +1/−1
• compiler/GHC/Core/Opt/CprAnal.hs +7/−9
• compiler/GHC/Core/Opt/DmdAnal.hs +272/−137
• compiler/GHC/Core/Opt/Pipeline.hs +15/−10
• compiler/GHC/Core/Opt/Simplify.hs +2/−1
• compiler/GHC/Core/Opt/Simplify/Env.hs +2/−3
• compiler/GHC/Core/Opt/WorkWrap.hs +5/−1
• compiler/GHC/Core/Opt/WorkWrap/Utils.hs +175/−115
• compiler/GHC/Core/Tidy.hs +2/−2
• compiler/GHC/CoreToStg/Prep.hs +3/−0
• compiler/GHC/Driver/Backpack.hs +133/−96
• compiler/GHC/Driver/CodeOutput.hs +6/−5
• compiler/GHC/Driver/Main.hs +55/−36
• compiler/GHC/Driver/Make.hs +431/−264
• compiler/GHC/Driver/MakeFile.hs +20/−7
• compiler/GHC/Driver/Pipeline.hs +202/−176
• compiler/GHC/HsToCore.hs +1/−5
• compiler/GHC/HsToCore/Binds.hs +1/−1
• compiler/GHC/HsToCore/Coverage.hs +1/−1
• compiler/GHC/HsToCore/Docs.hs +1/−1
• compiler/GHC/HsToCore/Expr.hs +3/−2
• compiler/GHC/HsToCore/Foreign/Call.hs +2/−1
• compiler/GHC/HsToCore/Match.hs +3/−3
• compiler/GHC/HsToCore/Match/Constructor.hs +2/−2
• compiler/GHC/HsToCore/Monad.hs +18/−15
• compiler/GHC/HsToCore/Pmc/Desugar.hs +1/−1
• compiler/GHC/HsToCore/Pmc/Solver.hs +1/−1
• compiler/GHC/HsToCore/Pmc/Solver/Types.hs +1/−1
• compiler/GHC/HsToCore/Quote.hs +12/−11
• compiler/GHC/HsToCore/Types.hs +4/−0
• compiler/GHC/HsToCore/Usage.hs +4/−6
• compiler/GHC/HsToCore/Utils.hs +8/−1
• compiler/GHC/Iface/Ext/Ast.hs +43/−22
• compiler/GHC/Iface/Ext/Utils.hs +1/−1
• compiler/GHC/Iface/Load.hs +318/−36
• compiler/GHC/Iface/Make.hs +6/−8
• compiler/GHC/Iface/Recomp.hs +5/−5
• compiler/GHC/Iface/Recomp/Flags.hs +7/−4
• compiler/GHC/Iface/Rename.hs +23/−20
• compiler/GHC/Iface/Tidy.hs +1/−4
• compiler/GHC/Linker/Dynamic.hs +13/−19
• compiler/GHC/Linker/ExtraObj.hs +62/−62
• compiler/GHC/Linker/Loader.hs +10/−10
• compiler/GHC/Linker/MacOS.hs +10/−40
• compiler/GHC/Linker/Static.hs +17/−26
• compiler/GHC/Linker/Unit.hs +12/−83
• compiler/GHC/Parser/Utils.hs +58/−0
• compiler/GHC/Rename/Bind.hs +10/−7
• compiler/GHC/Rename/Env.hs +27/−44
• compiler/GHC/Rename/Fixity.hs +1/−1
• compiler/GHC/Rename/HsType.hs +161/−32
• compiler/GHC/Rename/Module.hs +185/−77
• compiler/GHC/Rename/Names.hs +245/−104
• compiler/GHC/Rename/Pat.hs +26/−5
• compiler/GHC/Rename/Splice.hs +1/−1
• compiler/GHC/Rename/Unbound.hs +9/−11
• compiler/GHC/Rename/Utils.hs +28/−29
• compiler/GHC/Runtime/Eval.hs +4/−60
• compiler/GHC/Runtime/Heap/Inspect.hs +1/−1
• compiler/GHC/Runtime/Loader.hs +5/−5
• compiler/GHC/Stg/CSE.hs +5/−1
• compiler/GHC/Tc/Deriv/Generate.hs +113/−8
• compiler/GHC/Tc/Deriv/Utils.hs +2/−2
• compiler/GHC/Tc/Errors.hs +30/−25
• compiler/GHC/Tc/Errors/Hole.hs +10/−6
• compiler/GHC/Tc/Gen/App.hs +68/−20
• compiler/GHC/Tc/Gen/Arrow.hs +16/−12
• compiler/GHC/Tc/Gen/Bind.hs +1/−2
• compiler/GHC/Tc/Gen/Export.hs +86/−86
• compiler/GHC/Tc/Gen/Expr.hs +6/−9
• compiler/GHC/Tc/Gen/Head.hs +15/−30
• compiler/GHC/Tc/Gen/HsType.hs +76/−77
• compiler/GHC/Tc/Gen/Pat.hs +110/−20
• compiler/GHC/Tc/Gen/Rule.hs +1/−1
• compiler/GHC/Tc/Gen/Sig.hs +1/−1
• compiler/GHC/Tc/Gen/Splice.hs +1/−1
• compiler/GHC/Tc/Instance/Family.hs +1/−1
• compiler/GHC/Tc/Instance/Typeable.hs +1/−1
• compiler/GHC/Tc/Module.hs +14/−13
• compiler/GHC/Tc/Plugin.hs +1/−2
• compiler/GHC/Tc/Solver.hs +153/−415
• compiler/GHC/Tc/Solver/Canonical.hs +3214/−2623
• compiler/GHC/Tc/Solver/Flatten.hs +0/−1951
• compiler/GHC/Tc/Solver/Interact.hs +207/−604
• compiler/GHC/Tc/Solver/Monad.hs +3786/−3662
• compiler/GHC/Tc/Solver/Rewrite.hs +1033/−0
• compiler/GHC/Tc/TyCl.hs +284/−178
• compiler/GHC/Tc/TyCl/Instance.hs +90/−10
• compiler/GHC/Tc/TyCl/PatSyn.hs +20/−32
• compiler/GHC/Tc/Utils/Backpack.hs +40/−33
• compiler/GHC/Tc/Utils/Env.hs +36/−1
• compiler/GHC/Tc/Utils/Instantiate.hs +2/−1
• compiler/GHC/Tc/Utils/Monad.hs +25/−17
• compiler/GHC/Tc/Utils/TcMType.hs +71/−95
• compiler/GHC/Tc/Utils/Unify.hs +291/−286
• compiler/GHC/Tc/Utils/Zonk.hs +22/−10
• compiler/GHC/Tc/Validity.hs +0/−6
• compiler/GHC/ThToHs.hs +7/−5
• compiler/GHC/Types/Name/Shape.hs +12/−7
• compiler/GHC/Unit/Finder.hs +5/−248
• ghc-lib.cabal +11/−6
• ghc-lib/stage0/compiler/build/primop-docs.hs-incl +4/−0
• ghc-lib/stage0/lib/ghcversion.h +2/−3
• libraries/ghci/GHCi/CreateBCO.hs +1/−1
• libraries/ghci/GHCi/InfoTable.hsc +20/−61
• libraries/ghci/GHCi/ResolvedBCO.hs +1/−1

@@ -325,6 +325,7 @@ import GHC.Parser.Lexer import GHC.Parser.Annotation import GHC.Parser.Errors.Ppr+import GHC.Parser.Utils  import GHC.Iface.Load        ( loadSysInterface ) import GHC.Hs@@ -383,6 +384,7 @@ import GHC.Types.SourceFile  import GHC.Unit+import GHC.Unit.Env import GHC.Unit.External import GHC.Unit.State import GHC.Unit.Finder@@ -624,8 +626,9 @@ -- (packageFlags dflags). setSessionDynFlags :: GhcMonad m => DynFlags -> m () setSessionDynFlags dflags0 = do-  dflags1 <- checkNewDynFlags dflags0-  dflags <- liftIO $ initUnits dflags1+  dflags <- checkNewDynFlags dflags0+  hsc_env <- getSession+  (dbs,unit_state,home_unit) <- liftIO $ initUnits dflags (hsc_unit_dbs hsc_env)    -- Interpreter   interp  <- if gopt Opt_ExternalInterpreter dflags@@ -660,12 +663,19 @@       return Nothing #endif +  let unit_env = UnitEnv+        { ue_platform  = targetPlatform dflags+        , ue_namever   = ghcNameVersion dflags+        , ue_home_unit = home_unit+        , ue_units     = unit_state+        }   modifySession $ \h -> h{ hsc_dflags = dflags                          , hsc_IC = (hsc_IC h){ ic_dflags = dflags }                          , hsc_interp = hsc_interp h <|> interp                            -- we only update the interpreter if there wasn't                            -- already one set up-                         , hsc_home_unit = mkHomeUnitFromFlags dflags+                         , hsc_unit_env = unit_env+                         , hsc_unit_dbs = Just dbs                          }   invalidateModSummaryCache @@ -692,10 +702,21 @@   dflags' <- checkNewDynFlags dflags   dflags_prev <- getProgramDynFlags   let changed = packageFlagsChanged dflags_prev dflags'-  dflags'' <- if changed-               then liftIO $ initUnits dflags'-               else return dflags'-  modifySession $ \h -> h{ hsc_dflags = dflags'' }+  if changed+    then do+        hsc_env <- getSession+        (dbs,unit_state,home_unit) <- liftIO $ initUnits dflags' (hsc_unit_dbs hsc_env)+        let unit_env = UnitEnv+              { ue_platform  = targetPlatform dflags'+              , ue_namever   = ghcNameVersion dflags'+              , ue_home_unit = home_unit+              , ue_units     = unit_state+              }+        modifySession $ \h -> h{ hsc_dflags   = dflags'+                               , hsc_unit_dbs = Just dbs+                               , hsc_unit_env = unit_env+                               }+    else modifySession $ \h -> h{ hsc_dflags = dflags' }   when invalidate_needed $ invalidateModSummaryCache   return changed @@ -1291,11 +1312,7 @@  getPrintUnqual :: GhcMonad m => m PrintUnqualified getPrintUnqual = withSession $ \hsc_env -> do-  let dflags = hsc_dflags hsc_env-  return $ icPrintUnqual-               (unitState dflags)-               (hsc_home_unit hsc_env)-               (hsc_IC hsc_env)+  return $ icPrintUnqual (hsc_unit_env hsc_env) (hsc_IC hsc_env)  -- | Container for information about a 'Module'. data ModuleInfo = ModuleInfo {@@ -1347,6 +1364,18 @@                         minf_modBreaks = emptyModBreaks                 })) +availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv+availsToGlobalRdrEnv mod_name avails+  = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) avails)+  where+      -- We're building a GlobalRdrEnv as if the user imported+      -- all the specified modules into the global interactive module+    imp_spec = ImpSpec { is_decl = decl, is_item = ImpAll}+    decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,+                         is_qual = False,+                         is_dloc = srcLocSpan interactiveSrcLoc }++ getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) getHomeModuleInfo hsc_env mdl =   case lookupHpt (hsc_HPT hsc_env) (moduleName mdl) of@@ -1370,7 +1399,7 @@  modInfoTopLevelScope :: ModuleInfo -> Maybe [Name] modInfoTopLevelScope minf-  = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf)+  = fmap (map greMangledName . globalRdrEnvElts) (minf_rdr_env minf)  modInfoExports :: ModuleInfo -> [Name] modInfoExports minf = concatMap availNames $! minf_exports minf@@ -1390,10 +1419,7 @@                                ModuleInfo                             -> m (Maybe PrintUnqualified) -- XXX: returns a Maybe X mkPrintUnqualifiedForModule minf = withSession $ \hsc_env -> do-  let dflags          = hsc_dflags hsc_env-      mk_print_unqual = mkPrintUnqualified-                           (unitState dflags)-                           (hsc_home_unit hsc_env)+  let mk_print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env)   return (fmap mk_print_unqual (minf_rdr_env minf))  modInfoLookupName :: GhcMonad m =>@@ -1620,14 +1646,14 @@ -- using the algorithm that is used for an @import@ declaration. findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module findModule mod_name maybe_pkg = withSession $ \hsc_env -> do-  let dflags = hsc_dflags hsc_env-      home_unit = hsc_home_unit hsc_env+  let dflags     = hsc_dflags hsc_env+      home_unit  = hsc_home_unit hsc_env   case maybe_pkg of     Just pkg | not (isHomeUnit home_unit (fsToUnit pkg)) && pkg /= fsLit "this" -> liftIO $ do       res <- findImportedModule hsc_env mod_name maybe_pkg       case res of         Found _ m -> return m-        err       -> throwOneError $ noModError dflags noSrcSpan mod_name err+        err       -> throwOneError $ noModError hsc_env noSrcSpan mod_name err     _otherwise -> do       home <- lookupLoadedHomeModule mod_name       case home of@@ -1637,7 +1663,7 @@            case res of              Found loc m | not (isHomeModule home_unit m) -> return m                          | otherwise -> modNotLoadedError dflags m loc-             err -> throwOneError $ noModError dflags noSrcSpan mod_name err+             err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err  modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc dflags $@@ -1662,7 +1688,7 @@       res <- findExposedPackageModule hsc_env mod_name Nothing       case res of         Found _ m -> return m-        err       -> throwOneError $ noModError (hsc_dflags hsc_env) noSrcSpan mod_name err+        err       -> throwOneError $ noModError hsc_env noSrcSpan mod_name err  lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module) lookupLoadedHomeModule mod_name = withSession $ \hsc_env ->

@@ -265,7 +265,7 @@ ghcPrimExports  = map (avail . idName) ghcPrimIds ++    map (avail . idName . primOpId) allThePrimOps ++-   [ AvailTC n [n] []+   [ availTC n [n] []    | tc <- exposedPrimTyCons, let n = tyConName tc  ]  ghcPrimDeclDocs :: DeclDocMap

@@ -41,11 +41,10 @@  import GHC.Core.TyCon import GHC.Data.FastString+import GHC.Data.SizedSeq+ import GHC.StgToCmm.Layout     ( ArgRep(..) ) import GHC.Platform---- From iserv-import SizedSeq  import Control.Monad import Control.Monad.ST ( runST )

@@ -26,7 +26,6 @@ import GHCi.RemoteTypes import GHCi.ResolvedBCO import GHCi.BreakArray-import SizedSeq  import GHC.Builtin.PrimOps @@ -34,6 +33,7 @@ import GHC.Unit.Module.Name  import GHC.Data.FastString+import GHC.Data.SizedSeq  import GHC.Utils.Panic import GHC.Utils.Outputable

@@ -301,7 +301,7 @@              foldr blockCons code (map CmmTick ticks)  -- Group by [Label]--- See Note [Compressed TrieMap] in GHC.Core.Map about the usage of GenMap.+-- See Note [Compressed TrieMap] in GHC.Core.Map.Expr about the usage of GenMap. groupByLabel :: [(Key, DistinctBlocks)] -> [(Key, [DistinctBlocks])] groupByLabel =   go (TM.emptyTM :: TM.ListMap (TM.GenMap LabelMap) (Key, [DistinctBlocks]))

@@ -0,0 +1,53 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}++module GHC.Cmm.LRegSet (+    LRegSet,+    LRegKey,++    emptyLRegSet,+    nullLRegSet,+    insertLRegSet,+    elemLRegSet,++    deleteFromLRegSet,+    sizeLRegSet,++    plusLRegSet,+    elemsLRegSet+  ) where++import GHC.Prelude+import GHC.Types.Unique+import GHC.Cmm.Expr++import Data.IntSet as IntSet++-- Compact sets for membership tests of local variables.++type LRegSet = IntSet.IntSet+type LRegKey = Int++emptyLRegSet :: LRegSet+emptyLRegSet = IntSet.empty++nullLRegSet :: LRegSet -> Bool+nullLRegSet = IntSet.null++insertLRegSet :: LocalReg -> LRegSet -> LRegSet+insertLRegSet l = IntSet.insert (getKey (getUnique l))++elemLRegSet :: LocalReg -> LRegSet -> Bool+elemLRegSet l = IntSet.member (getKey (getUnique l))++deleteFromLRegSet :: LRegSet -> LocalReg -> LRegSet+deleteFromLRegSet set reg = IntSet.delete (getKey . getUnique $ reg) set++sizeLRegSet :: IntSet -> Int+sizeLRegSet = IntSet.size++plusLRegSet :: IntSet -> IntSet -> IntSet+plusLRegSet = IntSet.union++elemsLRegSet :: IntSet -> [Int]+elemsLRegSet = IntSet.toList

@@ -326,7 +326,7 @@     AlexEOF -> do let span = mkPsSpan loc1 loc1                   liftP (setLastToken span 0)                   return (L span CmmT_EOF)-    AlexError (loc2,_) -> liftP $ failLocMsgP (psRealLoc loc1) (psRealLoc loc2) (Error ErrCmmLexer [])+    AlexError (loc2,_) -> liftP $ failLocMsgP (psRealLoc loc1) (psRealLoc loc2) (PsError PsErrCmmLexer [])     AlexSkip inp2 _ -> do         setInput inp2         lexToken@@ -362,8 +362,8 @@         s'   = stepOn s  getInput :: PD AlexInput-getInput = PD $ \_ s@PState{ loc=l, buffer=b } -> POk s (l,b)+getInput = PD $ \_ _ s@PState{ loc=l, buffer=b } -> POk s (l,b)  setInput :: AlexInput -> PD ()-setInput (l,b) = PD $ \_ s -> POk s{ loc=l, buffer=b } ()+setInput (l,b) = PD $ \_ _ s -> POk s{ loc=l, buffer=b } () }

@@ -6,9 +6,12 @@ module GHC.Cmm.Liveness     ( CmmLocalLive     , cmmLocalLiveness+    , cmmLocalLivenessL     , cmmGlobalLiveness     , liveLattice+    , liveLatticeL     , gen_kill+    , gen_killL     ) where @@ -22,11 +25,14 @@ import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow import GHC.Cmm.Dataflow.Label+import GHC.Cmm.LRegSet  import GHC.Data.Maybe import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Types.Unique+ ----------------------------------------------------------------------------- -- Calculating what variables are live on entry to a basic block -----------------------------------------------------------------------------@@ -92,3 +98,66 @@     in mapSingleton (entryLabel eNode) result {-# SPECIALIZE xferLive :: Platform -> TransferFun (CmmLive LocalReg) #-} {-# SPECIALIZE xferLive :: Platform -> TransferFun (CmmLive GlobalReg) #-}++-----------------------------------------------------------------------------+-- | Specialization that only retains the keys for local variables.+--+-- Local variablas are mostly glorified Ints, and some parts of the compiler+-- really don't care about anything but the Int part. So we can avoid some+-- overhead by computing a IntSet instead of a Set LocalReg which (unsurprisingly)+-- is quite a bit faster.+-----------------------------------------------------------------------------++type BlockEntryLivenessL  = LabelMap LRegSet++-- | The dataflow lattice+liveLatticeL :: DataflowLattice LRegSet+liveLatticeL = DataflowLattice emptyLRegSet add+  where+    add (OldFact old) (NewFact new) =+        let !join = plusLRegSet old new+        in changedIf (sizeLRegSet join > sizeLRegSet old) join+++cmmLocalLivenessL :: Platform -> CmmGraph -> BlockEntryLivenessL+cmmLocalLivenessL platform graph =+    check $ analyzeCmmBwd liveLatticeL (xferLiveL platform) graph mapEmpty+  where+    entry = g_entry graph+    check facts =+        noLiveOnEntryL entry (expectJust "check" $ mapLookup entry facts) facts++-- | On entry to the procedure, there had better not be any LocalReg's live-in.+noLiveOnEntryL :: BlockId -> LRegSet -> a -> a+noLiveOnEntryL bid in_fact x =+  if nullLRegSet in_fact then x+  else pprPanic "LocalReg's live-in to graph" (ppr bid <+> ppr reg_uniques)+    where+        -- We convert the int's to uniques so that the printing matches that+        -- of registers.+        reg_uniques = map mkUniqueGrimily $ elemsLRegSet in_fact+++++gen_killL+    :: (DefinerOfRegs LocalReg n, UserOfRegs LocalReg n)+    => Platform -> n -> LRegSet -> LRegSet+gen_killL platform node set =+    let !afterKill = foldRegsDefd platform deleteFromLRegSet set node+    in foldRegsUsed platform (flip insertLRegSet) afterKill node+{-# INLINE gen_killL #-}++xferLiveL+    :: ( UserOfRegs LocalReg (CmmNode O O)+       , DefinerOfRegs LocalReg (CmmNode O O)+       , UserOfRegs LocalReg (CmmNode O C)+       , DefinerOfRegs LocalReg (CmmNode O C)+       )+    => Platform -> TransferFun LRegSet+xferLiveL platform (BlockCC eNode middle xNode) fBase =+    let joined = gen_killL platform xNode $! joinOutFacts liveLatticeL xNode fBase+        !result = foldNodesBwdOO (gen_killL platform) middle joined+    in mapSingleton (entryLabel eNode) result++

@@ -58,7 +58,7 @@     -> Maybe CmmExpr  cmmMachOpFoldM _ op [CmmLit (CmmInt x rep)]-  = Just $ case op of+  = Just $! case op of       MO_S_Neg _ -> CmmLit (CmmInt (-x) rep)       MO_Not _   -> CmmLit (CmmInt (complement x) rep) @@ -90,13 +90,13 @@         -- but remember to use the signedness from the widening, just in case         -- the final conversion is a widen.         | rep1 < rep2 && rep2 > rep3 ->-            Just $ cmmMachOpFold platform (intconv signed1 rep1 rep3) [x]+            Just $! cmmMachOpFold platform (intconv signed1 rep1 rep3) [x]         -- Nested widenings: collapse if the signedness is the same         | rep1 < rep2 && rep2 < rep3 && signed1 == signed2 ->-            Just $ cmmMachOpFold platform (intconv signed1 rep1 rep3) [x]+            Just $! cmmMachOpFold platform (intconv signed1 rep1 rep3) [x]         -- Nested narrowings: collapse         | rep1 > rep2 && rep2 > rep3 ->-            Just $ cmmMachOpFold platform (MO_UU_Conv rep1 rep3) [x]+            Just $! cmmMachOpFold platform (MO_UU_Conv rep1 rep3) [x]         | otherwise ->             Nothing   where@@ -117,34 +117,34 @@   = case mop of         -- for comparisons: don't forget to narrow the arguments before         -- comparing, since they might be out of range.-        MO_Eq _   -> Just $ CmmLit (CmmInt (if x_u == y_u then 1 else 0) (wordWidth platform))-        MO_Ne _   -> Just $ CmmLit (CmmInt (if x_u /= y_u then 1 else 0) (wordWidth platform))+        MO_Eq _   -> Just $! CmmLit (CmmInt (if x_u == y_u then 1 else 0) (wordWidth platform))+        MO_Ne _   -> Just $! CmmLit (CmmInt (if x_u /= y_u then 1 else 0) (wordWidth platform)) -        MO_U_Gt _ -> Just $ CmmLit (CmmInt (if x_u >  y_u then 1 else 0) (wordWidth platform))-        MO_U_Ge _ -> Just $ CmmLit (CmmInt (if x_u >= y_u then 1 else 0) (wordWidth platform))-        MO_U_Lt _ -> Just $ CmmLit (CmmInt (if x_u <  y_u then 1 else 0) (wordWidth platform))-        MO_U_Le _ -> Just $ CmmLit (CmmInt (if x_u <= y_u then 1 else 0) (wordWidth platform))+        MO_U_Gt _ -> Just $! CmmLit (CmmInt (if x_u >  y_u then 1 else 0) (wordWidth platform))+        MO_U_Ge _ -> Just $! CmmLit (CmmInt (if x_u >= y_u then 1 else 0) (wordWidth platform))+        MO_U_Lt _ -> Just $! CmmLit (CmmInt (if x_u <  y_u then 1 else 0) (wordWidth platform))+        MO_U_Le _ -> Just $! CmmLit (CmmInt (if x_u <= y_u then 1 else 0) (wordWidth platform)) -        MO_S_Gt _ -> Just $ CmmLit (CmmInt (if x_s >  y_s then 1 else 0) (wordWidth platform))-        MO_S_Ge _ -> Just $ CmmLit (CmmInt (if x_s >= y_s then 1 else 0) (wordWidth platform))-        MO_S_Lt _ -> Just $ CmmLit (CmmInt (if x_s <  y_s then 1 else 0) (wordWidth platform))-        MO_S_Le _ -> Just $ CmmLit (CmmInt (if x_s <= y_s then 1 else 0) (wordWidth platform))+        MO_S_Gt _ -> Just $! CmmLit (CmmInt (if x_s >  y_s then 1 else 0) (wordWidth platform))+        MO_S_Ge _ -> Just $! CmmLit (CmmInt (if x_s >= y_s then 1 else 0) (wordWidth platform))+        MO_S_Lt _ -> Just $! CmmLit (CmmInt (if x_s <  y_s then 1 else 0) (wordWidth platform))+        MO_S_Le _ -> Just $! CmmLit (CmmInt (if x_s <= y_s then 1 else 0) (wordWidth platform)) -        MO_Add r -> Just $ CmmLit (CmmInt (x + y) r)-        MO_Sub r -> Just $ CmmLit (CmmInt (x - y) r)-        MO_Mul r -> Just $ CmmLit (CmmInt (x * y) r)-        MO_U_Quot r | y /= 0 -> Just $ CmmLit (CmmInt (x_u `quot` y_u) r)-        MO_U_Rem  r | y /= 0 -> Just $ CmmLit (CmmInt (x_u `rem`  y_u) r)-        MO_S_Quot r | y /= 0 -> Just $ CmmLit (CmmInt (x `quot` y) r)-        MO_S_Rem  r | y /= 0 -> Just $ CmmLit (CmmInt (x `rem` y) r)+        MO_Add r -> Just $! CmmLit (CmmInt (x + y) r)+        MO_Sub r -> Just $! CmmLit (CmmInt (x - y) r)+        MO_Mul r -> Just $! CmmLit (CmmInt (x * y) r)+        MO_U_Quot r | y /= 0 -> Just $! CmmLit (CmmInt (x_u `quot` y_u) r)+        MO_U_Rem  r | y /= 0 -> Just $! CmmLit (CmmInt (x_u `rem`  y_u) r)+        MO_S_Quot r | y /= 0 -> Just $! CmmLit (CmmInt (x `quot` y) r)+        MO_S_Rem  r | y /= 0 -> Just $! CmmLit (CmmInt (x `rem` y) r) -        MO_And   r -> Just $ CmmLit (CmmInt (x .&. y) r)-        MO_Or    r -> Just $ CmmLit (CmmInt (x .|. y) r)-        MO_Xor   r -> Just $ CmmLit (CmmInt (x `xor` y) r)+        MO_And   r -> Just $! CmmLit (CmmInt (x .&. y) r)+        MO_Or    r -> Just $! CmmLit (CmmInt (x .|. y) r)+        MO_Xor   r -> Just $! CmmLit (CmmInt (x `xor` y) r) -        MO_Shl   r -> Just $ CmmLit (CmmInt (x `shiftL` fromIntegral y) r)-        MO_U_Shr r -> Just $ CmmLit (CmmInt (x_u `shiftR` fromIntegral y) r)-        MO_S_Shr r -> Just $ CmmLit (CmmInt (x `shiftR` fromIntegral y) r)+        MO_Shl   r -> Just $! CmmLit (CmmInt (x `shiftL` fromIntegral y) r)+        MO_U_Shr r -> Just $! CmmLit (CmmInt (x_u `shiftR` fromIntegral y) r)+        MO_S_Shr r -> Just $! CmmLit (CmmInt (x `shiftR` fromIntegral y) r)          _          -> Nothing @@ -162,7 +162,7 @@  cmmMachOpFoldM platform op [x@(CmmLit _), y]    | not (isLit y) && isCommutableMachOp op-   = Just (cmmMachOpFold platform op [y, x])+   = Just $! (cmmMachOpFold platform op [y, x])  -- Turn (a+b)+c into a+(b+c) where possible.  Because literals are -- moved to the right, it is more likely that we will find@@ -183,7 +183,7 @@ cmmMachOpFoldM platform mop1 [CmmMachOp mop2 [arg1,arg2], arg3]    | mop2 `associates_with` mop1      && not (isLit arg1) && not (isPicReg arg1)-   = Just (cmmMachOpFold platform mop2 [arg1, cmmMachOpFold platform mop1 [arg2,arg3]])+   = Just $! (cmmMachOpFold platform mop2 [arg1, cmmMachOpFold platform mop1 [arg2,arg3]])    where      MO_Add{} `associates_with` MO_Sub{} = True      mop1 `associates_with` mop2 =@@ -192,7 +192,7 @@ -- special case: (a - b) + c  ==>  a + (c - b) cmmMachOpFoldM platform mop1@(MO_Add{}) [CmmMachOp mop2@(MO_Sub{}) [arg1,arg2], arg3]    | not (isLit arg1) && not (isPicReg arg1)-   = Just (cmmMachOpFold platform mop1 [arg1, cmmMachOpFold platform mop2 [arg3,arg2]])+   = Just $! (cmmMachOpFold platform mop1 [arg1, cmmMachOpFold platform mop2 [arg3,arg2]])  -- special case: (PicBaseReg + lit) + N  ==>  PicBaseReg + (lit+N) --@@ -205,27 +205,27 @@ cmmMachOpFoldM _ MO_Add{} [ CmmMachOp op@MO_Add{} [pic, CmmLit lit]                           , CmmLit (CmmInt n rep) ]   | isPicReg pic-  = Just $ CmmMachOp op [pic, CmmLit $ cmmOffsetLit lit off ]+  = Just $! CmmMachOp op [pic, CmmLit $ cmmOffsetLit lit off ]   where off = fromIntegral (narrowS rep n)  -- Make a RegOff if we can cmmMachOpFoldM _ (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)]-  = Just $ cmmRegOff reg (fromIntegral (narrowS rep n))+  = Just $! cmmRegOff reg (fromIntegral (narrowS rep n)) cmmMachOpFoldM _ (MO_Add _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]-  = Just $ cmmRegOff reg (off + fromIntegral (narrowS rep n))+  = Just $! cmmRegOff reg (off + fromIntegral (narrowS rep n)) cmmMachOpFoldM _ (MO_Sub _) [CmmReg reg, CmmLit (CmmInt n rep)]-  = Just $ cmmRegOff reg (- fromIntegral (narrowS rep n))+  = Just $! cmmRegOff reg (- fromIntegral (narrowS rep n)) cmmMachOpFoldM _ (MO_Sub _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]-  = Just $ cmmRegOff reg (off - fromIntegral (narrowS rep n))+  = Just $! cmmRegOff reg (off - fromIntegral (narrowS rep n))  -- Fold label(+/-)offset into a CmmLit where possible  cmmMachOpFoldM _ (MO_Add _) [CmmLit lit, CmmLit (CmmInt i rep)]-  = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i)))+  = Just $! CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i))) cmmMachOpFoldM _ (MO_Add _) [CmmLit (CmmInt i rep), CmmLit lit]-  = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i)))+  = Just $! CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i))) cmmMachOpFoldM _ (MO_Sub _) [CmmLit lit, CmmLit (CmmInt i rep)]-  = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (negate (narrowU rep i))))+  = Just $! CmmLit (cmmOffsetLit lit (fromIntegral (negate (narrowU rep i))))   -- Comparison of literal with widened operand: perform the comparison@@ -245,7 +245,7 @@         -- and the literal fits in the smaller size:     i == narrow_fn rep i         -- then we can do the comparison at the smaller size-  = Just (cmmMachOpFold platform narrow_cmp [x, CmmLit (CmmInt i rep)])+  = Just $! (cmmMachOpFold platform narrow_cmp [x, CmmLit (CmmInt i rep)])  where     maybe_conversion (MO_UU_Conv from to)         | to > from@@ -320,8 +320,8 @@         MO_Mul    _ -> Just x         MO_S_Quot _ -> Just x         MO_U_Quot _ -> Just x-        MO_S_Rem  _ -> Just $ CmmLit (CmmInt 0 rep)-        MO_U_Rem  _ -> Just $ CmmLit (CmmInt 0 rep)+        MO_S_Rem  _ -> Just $! CmmLit (CmmInt 0 rep)+        MO_U_Rem  _ -> Just $! CmmLit (CmmInt 0 rep)          -- Comparisons; trickier         -- See Note [Comparison operators]@@ -346,18 +346,18 @@   = case mop of         MO_Mul rep            | Just p <- exactLog2 n ->-                 Just (cmmMachOpFold platform (MO_Shl rep) [x, CmmLit (CmmInt p rep)])+                 Just $! (cmmMachOpFold platform (MO_Shl rep) [x, CmmLit (CmmInt p rep)])         MO_U_Quot rep            | Just p <- exactLog2 n ->-                 Just (cmmMachOpFold platform (MO_U_Shr rep) [x, CmmLit (CmmInt p rep)])+                 Just $! (cmmMachOpFold platform (MO_U_Shr rep) [x, CmmLit (CmmInt p rep)])         MO_U_Rem rep            | Just _ <- exactLog2 n ->-                 Just (cmmMachOpFold platform (MO_And rep) [x, CmmLit (CmmInt (n - 1) rep)])+                 Just $! (cmmMachOpFold platform (MO_And rep) [x, CmmLit (CmmInt (n - 1) rep)])         MO_S_Quot rep            | Just p <- exactLog2 n,              CmmReg _ <- x ->   -- We duplicate x in signedQuotRemHelper, hence require                                 -- it is a reg.  FIXME: remove this restriction.-                Just (cmmMachOpFold platform (MO_S_Shr rep)+                Just $! (cmmMachOpFold platform (MO_S_Shr rep)                   [signedQuotRemHelper rep p, CmmLit (CmmInt p rep)])         MO_S_Rem rep            | Just p <- exactLog2 n,@@ -366,7 +366,7 @@                 -- We replace (x `rem` 2^p) by (x - (x `quot` 2^p) * 2^p).                 -- Moreover, we fuse MO_S_Shr (last operation of MO_S_Quot)                 -- and MO_S_Shl (multiplication by 2^p) into a single MO_And operation.-                Just (cmmMachOpFold platform (MO_Sub rep)+                Just $! (cmmMachOpFold platform (MO_Sub rep)                     [x, cmmMachOpFold platform (MO_And rep)                       [signedQuotRemHelper rep p, CmmLit (CmmInt (- n) rep)]])         _ -> Nothing

@@ -244,6 +244,7 @@ import GHC.Types.CostCentre import GHC.Types.ForeignCall import GHC.Unit.Module+import GHC.Unit.Home import GHC.Types.Literal import GHC.Types.Unique import GHC.Types.Unique.FM@@ -918,7 +919,7 @@ nameToMachOp :: FastString -> PD (Width -> MachOp) nameToMachOp name =   case lookupUFM machOps name of-        Nothing -> failMsgPD $ Error (ErrCmmParser (CmmUnknownPrimitive name)) []+        Nothing -> failMsgPD $ PsError (PsErrCmmParser (CmmUnknownPrimitive name)) []         Just m  -> return m  exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr)@@ -1080,12 +1081,12 @@ parseSafety "safe"   = return PlaySafe parseSafety "unsafe" = return PlayRisky parseSafety "interruptible" = return PlayInterruptible-parseSafety str      = failMsgPD $ Error (ErrCmmParser (CmmUnrecognisedSafety str)) []+parseSafety str      = failMsgPD $ PsError (PsErrCmmParser (CmmUnrecognisedSafety str)) []  parseCmmHint :: String -> PD ForeignHint parseCmmHint "ptr"    = return AddrHint parseCmmHint "signed" = return SignedHint-parseCmmHint str      = failMsgPD $ Error (ErrCmmParser (CmmUnrecognisedHint str)) []+parseCmmHint str      = failMsgPD $ PsError (PsErrCmmParser (CmmUnrecognisedHint str)) []  -- labels are always pointers, so we might as well infer the hint inferCmmHint :: CmmExpr -> ForeignHint@@ -1104,7 +1105,7 @@ isPtrGlobalReg _                     = False  happyError :: PD a-happyError = PD $ \_ s -> unP srcParseFail s+happyError = PD $ \_ _ s -> unP srcParseFail s  -- ----------------------------------------------------------------------------- -- Statement-level macros@@ -1112,7 +1113,7 @@ stmtMacro :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse ()) stmtMacro fun args_code = do   case lookupUFM stmtMacros fun of-    Nothing -> failMsgPD $ Error (ErrCmmParser (CmmUnknownMacro fun)) []+    Nothing -> failMsgPD $ PsError (PsErrCmmParser (CmmUnknownMacro fun)) []     Just fcode -> return $ do         args <- sequence args_code         code (fcode args)@@ -1215,7 +1216,7 @@   = do  conv <- case conv_string of           "C"       -> return CCallConv           "stdcall" -> return StdCallConv-          _         -> failMsgPD $ Error (ErrCmmParser (CmmUnknownCConv conv_string)) []+          _         -> failMsgPD $ PsError (PsErrCmmParser (CmmUnknownCConv conv_string)) []         return $ do           platform <- getPlatform           results <- sequence results_code@@ -1293,7 +1294,7 @@   = do     platform <- PD.getPlatform     case lookupUFM (callishMachOps platform) name of-        Nothing -> failMsgPD $ Error (ErrCmmParser (CmmUnknownPrimitive name)) []+        Nothing -> failMsgPD $ PsError (PsErrCmmParser (CmmUnknownPrimitive name)) []         Just f  -> return $ do                 results <- sequence results_code                 args <- sequence args_code@@ -1447,8 +1448,8 @@   ]   where platform = profilePlatform profile -parseCmmFile :: DynFlags -> FilePath -> IO (Bag Warning, Bag Error, Maybe CmmGroup)-parseCmmFile dflags filename = do+parseCmmFile :: DynFlags -> HomeUnit -> FilePath -> IO (Bag PsWarning, Bag PsError, Maybe CmmGroup)+parseCmmFile dflags home_unit filename = do   buf <- hGetStringBuffer filename   let         init_loc = mkRealSrcLoc (mkFastString filename) 1 1@@ -1456,7 +1457,7 @@         init_state = (initParserState opts buf init_loc) { lex_state = [0] }                 -- reset the lex_state: the Lexer monad leaves some stuff                 -- in there we don't want.-  case unPD cmmParse dflags init_state of+  case unPD cmmParse dflags home_unit init_state of     PFailed pst -> do         let (warnings,errors) = getMessages pst         return (warnings, errors, Nothing)

@@ -32,7 +32,7 @@ import GHC.Unit.Types import GHC.Unit.Home -newtype PD a = PD { unPD :: DynFlags -> PState -> ParseResult a }+newtype PD a = PD { unPD :: DynFlags -> HomeUnit -> PState -> ParseResult a }  instance Functor PD where   fmap = liftM@@ -45,22 +45,22 @@   (>>=) = thenPD  liftP :: P a -> PD a-liftP (P f) = PD $ \_ s -> f s+liftP (P f) = PD $ \_ _ s -> f s -failMsgPD :: (SrcSpan -> Error) -> PD a+failMsgPD :: (SrcSpan -> PsError) -> PD a failMsgPD = liftP . failMsgP  returnPD :: a -> PD a returnPD = liftP . return  thenPD :: PD a -> (a -> PD b) -> PD b-(PD m) `thenPD` k = PD $ \d s ->-        case m d s of-                POk s1 a         -> unPD (k a) d s1+(PD m) `thenPD` k = PD $ \d hu s ->+        case m d hu s of+                POk s1 a   -> unPD (k a) d hu s1                 PFailed s1 -> PFailed s1  instance HasDynFlags PD where-   getDynFlags = PD $ \d s -> POk s d+   getDynFlags = PD $ \d _ s -> POk s d  getProfile :: PD Profile getProfile = targetProfile <$> getDynFlags@@ -79,6 +79,4 @@  -- | Return the UnitId of the home-unit. This is used to create labels. getHomeUnitId :: PD UnitId-getHomeUnitId = do-   dflags <- getDynFlags-   pure (homeUnitId (mkHomeUnitFromFlags dflags))+getHomeUnitId = PD $ \_ hu s -> POk s (homeUnitId hu)

@@ -1,4 +1,6 @@ {-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+ module GHC.Cmm.Sink (      cmmSink   ) where@@ -8,6 +10,7 @@ import GHC.Cmm import GHC.Cmm.Opt import GHC.Cmm.Liveness+import GHC.Cmm.LRegSet import GHC.Cmm.Utils import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Label@@ -16,29 +19,13 @@ import GHC.Platform.Regs  import GHC.Platform-import GHC.Types.Unique import GHC.Types.Unique.FM  import qualified Data.IntSet as IntSet import Data.List (partition)-import qualified Data.Set as Set import Data.Maybe --- Compact sets for membership tests of local variables.--type LRegSet = IntSet.IntSet--emptyLRegSet :: LRegSet-emptyLRegSet = IntSet.empty--nullLRegSet :: LRegSet -> Bool-nullLRegSet = IntSet.null--insertLRegSet :: LocalReg -> LRegSet -> LRegSet-insertLRegSet l = IntSet.insert (getKey (getUnique l))--elemLRegSet :: LocalReg -> LRegSet -> Bool-elemLRegSet l = IntSet.member (getKey (getUnique l))+import GHC.Exts (inline)  -- ----------------------------------------------------------------------------- -- Sinking and inlining@@ -167,8 +154,8 @@ cmmSink :: Platform -> CmmGraph -> CmmGraph cmmSink platform graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks   where-  liveness = cmmLocalLiveness platform graph-  getLive l = mapFindWithDefault Set.empty l liveness+  liveness = cmmLocalLivenessL platform graph+  getLive l = mapFindWithDefault emptyLRegSet l liveness    blocks = revPostorder graph @@ -188,8 +175,8 @@       -- Annotate the middle nodes with the registers live *after*       -- the node.  This will help us decide whether we can inline       -- an assignment in the current node or not.-      live = Set.unions (map getLive succs)-      live_middle = gen_kill platform last live+      live = IntSet.unions (map getLive succs)+      live_middle = gen_killL platform last live       ann_middles = annotate platform live_middle (blockToList middle)        -- Now sink and inline in this block@@ -201,7 +188,7 @@       -- one predecessor), so identify the join points and the set       -- of registers live in them.       (joins, nonjoins) = partition (`mapMember` join_pts) succs-      live_in_joins = Set.unions (map getLive joins)+      live_in_joins = IntSet.unions (map getLive joins)        -- We do not want to sink an assignment into multiple branches,       -- so identify the set of registers live in multiple successors.@@ -210,26 +197,28 @@       -- now live in multiple branches.       init_live_sets = map getLive nonjoins       live_in_multi live_sets r =-         case filter (Set.member r) live_sets of+         case filter (elemLRegSet r) live_sets of            (_one:_two:_) -> True            _ -> False        -- Now, drop any assignments that we will not sink any further.       (dropped_last, assigs'') = dropAssignments platform drop_if init_live_sets assigs' +      drop_if :: (LocalReg, CmmExpr, AbsMem)+                      -> [LRegSet] -> (Bool, [LRegSet])       drop_if a@(r,rhs,_) live_sets = (should_drop, live_sets')           where             should_drop =  conflicts platform a final_last                         || not (isTrivial platform rhs) && live_in_multi live_sets r-                        || r `Set.member` live_in_joins+                        || r `elemLRegSet` live_in_joins              live_sets' | should_drop = live_sets                        | otherwise   = map upd live_sets -            upd set | r `Set.member` set = set `Set.union` live_rhs+            upd set | r `elemLRegSet` set = set `IntSet.union` live_rhs                     | otherwise          = set -            live_rhs = foldRegsUsed platform extendRegSet emptyRegSet rhs+            live_rhs = foldRegsUsed platform (flip insertLRegSet) emptyLRegSet rhs        final_middle = foldl' blockSnoc middle' dropped_last @@ -266,9 +255,9 @@ -- -- annotate each node with the set of registers live *after* the node ---annotate :: Platform -> LocalRegSet -> [CmmNode O O] -> [(LocalRegSet, CmmNode O O)]+annotate :: Platform -> LRegSet -> [CmmNode O O] -> [(LRegSet, CmmNode O O)] annotate platform live nodes = snd $ foldr ann (live,[]) nodes-  where ann n (live,nodes) = (gen_kill platform n live, (live,n) : nodes)+  where ann n (live,nodes) = (gen_killL platform n live, (live,n) : nodes)  -- -- Find the blocks that have multiple successors (join points)@@ -285,13 +274,13 @@ -- filter the list of assignments to remove any assignments that -- are not live in a continuation. ---filterAssignments :: Platform -> LocalRegSet -> Assignments -> Assignments+filterAssignments :: Platform -> LRegSet -> Assignments -> Assignments filterAssignments platform live assigs = reverse (go assigs [])   where go []             kept = kept         go (a@(r,_,_):as) kept | needed    = go as (a:kept)                                | otherwise = go as kept            where-              needed = r `Set.member` live+              needed = r `elemLRegSet` live                        || any (conflicts platform a) (map toNode kept)                        --  Note that we must keep assignments that are                        -- referred to by other assignments we have@@ -312,7 +301,7 @@ --  walk :: Platform-     -> [(LocalRegSet, CmmNode O O)]    -- nodes of the block, annotated with+     -> [(LRegSet, CmmNode O O)]    -- nodes of the block, annotated with                                         -- the set of registers live *after*                                         -- this node. @@ -366,11 +355,11 @@ -- out of inlining, but the inliner will see that r is live -- after the instruction and choose not to inline r in the rhs. ---shouldDiscard :: CmmNode e x -> LocalRegSet -> Bool+shouldDiscard :: CmmNode e x -> LRegSet -> Bool shouldDiscard node live    = case node of        CmmAssign r (CmmReg r') | r == r' -> True-       CmmAssign (CmmLocal r) _ -> not (r `Set.member` live)+       CmmAssign (CmmLocal r) _ -> not (r `elemLRegSet` live)        _otherwise -> False  @@ -403,8 +392,9 @@ -- inlining opens up opportunities for doing so.  tryToInline-   :: Platform-   -> LocalRegSet               -- set of registers live after this+   :: forall x. Platform+   -> LRegSet               -- set of registers live after this+  --  -> LocalRegSet               -- set of registers live after this                                 -- node.  We cannot inline anything                                 -- that is live after the node, unless                                 -- it is small enough to duplicate.@@ -415,43 +405,50 @@       , Assignments             -- Remaining assignments       ) -tryToInline platform live node assigs = go usages node emptyLRegSet assigs+tryToInline platform liveAfter node assigs =+  -- pprTrace "tryToInline assig length:" (ppr $ length assigs) $+    go usages liveAfter node emptyLRegSet assigs  where   usages :: UniqFM LocalReg Int -- Maps each LocalReg to a count of how often it is used   usages = foldLocalRegsUsed platform addUsage emptyUFM node -  go _usages node _skipped [] = (node, [])+  go :: UniqFM LocalReg Int -> LRegSet -> CmmNode O x -> LRegSet -> Assignments+     -> (CmmNode O x, Assignments)+  go _usages _live node _skipped [] = (node, []) -  go usages node skipped (a@(l,rhs,_) : rest)-   | cannot_inline           = dont_inline-   | occurs_none             = discard  -- Note [discard during inlining]-   | occurs_once             = inline_and_discard-   | isTrivial platform rhs  = inline_and_keep-   | otherwise               = dont_inline+  go usages live node skipped (a@(l,rhs,_) : rest)+   | cannot_inline            = dont_inline+   | occurs_none              = discard  -- Note [discard during inlining]+   | occurs_once              = inline_and_discard+   | isTrivial platform rhs   = inline_and_keep+   | otherwise                = dont_inline    where-        inline_and_discard = go usages' inl_node skipped rest+        inline_and_discard = go usages' live inl_node skipped rest           where usages' = foldLocalRegsUsed platform addUsage usages rhs -        discard = go usages node skipped rest+        discard = go usages live node skipped rest          dont_inline        = keep node  -- don't inline the assignment, keep it         inline_and_keep    = keep inl_node -- inline the assignment, keep it +        keep :: CmmNode O x -> (CmmNode O x, Assignments)         keep node' = (final_node, a : rest')-          where (final_node, rest') = go usages' node' (insertLRegSet l skipped) rest-                usages' = foldLocalRegsUsed platform (\m r -> addToUFM m r 2)-                                            usages rhs-                -- we must not inline anything that is mentioned in the RHS-                -- of a binding that we have already skipped, so we set the-                -- usages of the regs on the RHS to 2.+          where (final_node, rest') = go usages live' node' (insertLRegSet l skipped) rest +                -- Avoid discarding of assignments to vars on the rhs.+                -- See Note [Keeping assignemnts mentioned in skipped RHSs]+                -- usages' = foldLocalRegsUsed platform (\m r -> addToUFM m r 2)+                                            -- usages rhs+                live' = inline foldLocalRegsUsed platform (\m r -> insertLRegSet r m)+                                            live rhs+         cannot_inline = skipped `regsUsedIn` rhs -- Note [dependent assignments]                         || l `elemLRegSet` skipped                         || not (okToInline platform rhs node)          -- How often is l used in the current node.         l_usages = lookupUFM usages l-        l_live   = l `elemRegSet` live+        l_live   = l `elemLRegSet` live          occurs_once = not l_live && l_usages == Just 1         occurs_none = not l_live && l_usages == Nothing@@ -467,7 +464,28 @@         inl_exp (CmmMachOp op args) = cmmMachOpFold platform op args         inl_exp other = other +{- Note [Keeping assignemnts mentioned in skipped RHSs]+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +    If we have to assignments: [z = y, y = e1] and we skip+    z we *must* retain the assignment y = e1. This is because+    we might inline "z = y" into another node later on so we+    must ensure y is still defined at this point.++    If we dropped the assignment of "y = e1" then we would end up+    referencing a variable which hasn't been mentioned after+    inlining.++    We use a hack to do this.++    We pretend the regs from the rhs are live after the current+    node. Since we only discard assignments to variables+    which are dead after the current block this prevents discarding of the+    assignment. It still allows inlining should e1 be a trivial rhs+    however.++-}+ {- Note [improveConditional]  cmmMachOpFold tries to simplify conditionals to turn things like@@ -610,18 +628,34 @@   -- (7) otherwise, no conflict   | otherwise = False +{- Note [Inlining foldRegsDefd]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~++   foldRegsDefd is, after optimization, *not* a small function so+   it's only marked INLINEABLE, but not INLINE.++   However in some specific cases we call it *very* often making it+   important to avoid the overhead of allocating the folding function.++   So we simply force inlining via the magic inline function.+   For T3294 this improves allocation with -O by ~1%.++-}+ -- Returns True if node defines any global registers that are used in the -- Cmm expression globalRegistersConflict :: Platform -> CmmExpr -> CmmNode e x -> Bool globalRegistersConflict platform expr node =-    foldRegsDefd platform (\b r -> b || regUsedIn platform (CmmGlobal r) expr)+    -- See Note [Inlining foldRegsDefd]+    inline foldRegsDefd platform (\b r -> b || regUsedIn platform (CmmGlobal r) expr)                  False node  -- Returns True if node defines any local registers that are used in the -- Cmm expression localRegistersConflict :: Platform -> CmmExpr -> CmmNode e x -> Bool localRegistersConflict platform expr node =-    foldRegsDefd platform (\b r -> b || regUsedIn platform (CmmLocal  r) expr)+    -- See Note [Inlining foldRegsDefd]+    inline foldRegsDefd platform (\b r -> b || regUsedIn platform (CmmLocal  r) expr)                  False node  -- Note [Sinking and calls]

@@ -264,9 +264,11 @@    CmmStackSlot area off -> CmmStackSlot area (off - byte_off)   -- note stack area offsets increase towards lower addresses    CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]-      -> CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt (byte_off1 + toInteger byte_off) rep)]-   _ -> CmmMachOp (MO_Add width) [e, CmmLit (CmmInt (toInteger byte_off) width)]-         where width = cmmExprWidth platform e+      -> let !lit_off = (byte_off1 + toInteger byte_off)+         in CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt lit_off rep)]+   _ -> let !width = cmmExprWidth platform e+        in+        CmmMachOp (MO_Add width) [e, CmmLit (CmmInt (toInteger byte_off) width)]  -- Smart constructor for CmmRegOff.  Same caveats as cmmOffset above. cmmRegOff :: CmmReg -> Int -> CmmExpr

@@ -0,0 +1,392 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++{-# OPTIONS_GHC -Wno-orphans #-}+ -- Eq (DeBruijn CoreExpr) and Eq (DeBruijn CoreAlt)++module GHC.Core.Map.Expr (+   -- * Maps over Core expressions+   CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap,+   -- * 'TrieMap' class reexports+   TrieMap(..), insertTM, deleteTM,+   lkDFreeVar, xtDFreeVar,+   lkDNamed, xtDNamed,+   (>.>), (|>), (|>>),+ ) where++#include "GhclibHsVersions.h"++import GHC.Prelude++import GHC.Data.TrieMap+import GHC.Core.Map.Type+import GHC.Core+import GHC.Core.Type+import GHC.Types.Var++import GHC.Utils.Misc+import GHC.Utils.Outputable++import qualified Data.Map    as Map+import GHC.Types.Name.Env+import Control.Monad( (>=>) )++{-+This module implements TrieMaps over Core related data structures+like CoreExpr or Type. It is built on the Tries from the TrieMap+module.++The code is very regular and boilerplate-like, but there is+some neat handling of *binders*.  In effect they are deBruijn+numbered on the fly.+++-}++----------------------+-- Recall that+--   Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c++-- The CoreMap makes heavy use of GenMap. However the CoreMap Types are not+-- known when defining GenMap so we can only specialize them here.++{-# SPECIALIZE lkG :: Key CoreMapX     -> CoreMapG a     -> Maybe a #-}+{-# SPECIALIZE xtG :: Key CoreMapX     -> XT a -> CoreMapG a -> CoreMapG a #-}+{-# SPECIALIZE mapG :: (a -> b) -> CoreMapG a     -> CoreMapG b #-}+{-# SPECIALIZE fdG :: (a -> b -> b) -> CoreMapG a     -> b -> b #-}+++{-+************************************************************************+*                                                                      *+                   CoreMap+*                                                                      *+************************************************************************+-}++{-+Note [Binders]+~~~~~~~~~~~~~~+ * In general we check binders as late as possible because types are+   less likely to differ than expression structure.  That's why+      cm_lam :: CoreMapG (TypeMapG a)+   rather than+      cm_lam :: TypeMapG (CoreMapG a)++ * We don't need to look at the type of some binders, notably+     - the case binder in (Case _ b _ _)+     - the binders in an alternative+   because they are totally fixed by the context++Note [Empty case alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* For a key (Case e b ty (alt:alts))  we don't need to look the return type+  'ty', because every alternative has that type.++* For a key (Case e b ty []) we MUST look at the return type 'ty', because+  otherwise (Case (error () "urk") _ Int  []) would compare equal to+            (Case (error () "urk") _ Bool [])+  which is utterly wrong (#6097)++We could compare the return type regardless, but the wildly common case+is that it's unnecessary, so we have two fields (cm_case and cm_ecase)+for the two possibilities.  Only cm_ecase looks at the type.++See also Note [Empty case alternatives] in GHC.Core.+-}++-- | @CoreMap a@ is a map from 'CoreExpr' to @a@.  If you are a client, this+-- is the type you want.+newtype CoreMap a = CoreMap (CoreMapG a)++instance TrieMap CoreMap where+    type Key CoreMap = CoreExpr+    emptyTM = CoreMap emptyTM+    lookupTM k (CoreMap m) = lookupTM (deBruijnize k) m+    alterTM k f (CoreMap m) = CoreMap (alterTM (deBruijnize k) f m)+    foldTM k (CoreMap m) = foldTM k m+    mapTM f (CoreMap m) = CoreMap (mapTM f m)+    filterTM f (CoreMap m) = CoreMap (filterTM f m)++-- | @CoreMapG a@ is a map from @DeBruijn CoreExpr@ to @a@.  The extended+-- key makes it suitable for recursive traversal, since it can track binders,+-- but it is strictly internal to this module.  If you are including a 'CoreMap'+-- inside another 'TrieMap', this is the type you want.+type CoreMapG = GenMap CoreMapX++-- | @CoreMapX a@ is the base map from @DeBruijn CoreExpr@ to @a@, but without+-- the 'GenMap' optimization.+data CoreMapX a+  = CM { cm_var   :: VarMap a+       , cm_lit   :: LiteralMap a+       , cm_co    :: CoercionMapG a+       , cm_type  :: TypeMapG a+       , cm_cast  :: CoreMapG (CoercionMapG a)+       , cm_tick  :: CoreMapG (TickishMap a)+       , cm_app   :: CoreMapG (CoreMapG a)+       , cm_lam   :: CoreMapG (BndrMap a)    -- Note [Binders]+       , cm_letn  :: CoreMapG (CoreMapG (BndrMap a))+       , cm_letr  :: ListMap CoreMapG (CoreMapG (ListMap BndrMap a))+       , cm_case  :: CoreMapG (ListMap AltMap a)+       , cm_ecase :: CoreMapG (TypeMapG a)    -- Note [Empty case alternatives]+     }++instance Eq (DeBruijn CoreExpr) where+  D env1 e1 == D env2 e2 = go e1 e2 where+    go (Var v1) (Var v2)+      = case (lookupCME env1 v1, lookupCME env2 v2) of+                            (Just b1, Just b2) -> b1 == b2+                            (Nothing, Nothing) -> v1 == v2+                            _ -> False+    go (Lit lit1)    (Lit lit2)      = lit1 == lit2+    go (Type t1)    (Type t2)        = D env1 t1 == D env2 t2+    go (Coercion co1) (Coercion co2) = D env1 co1 == D env2 co2+    go (Cast e1 co1) (Cast e2 co2) = D env1 co1 == D env2 co2 && go e1 e2+    go (App f1 a1)   (App f2 a2)   = go f1 f2 && go a1 a2+    -- This seems a bit dodgy, see 'eqTickish'+    go (Tick n1 e1)  (Tick n2 e2)  = n1 == n2 && go e1 e2++    go (Lam b1 e1)  (Lam b2 e2)+      =  D env1 (varType b1) == D env2 (varType b2)+      && D env1 (varMultMaybe b1) == D env2 (varMultMaybe b2)+      && D (extendCME env1 b1) e1 == D (extendCME env2 b2) e2++    go (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2)+      =  go r1 r2+      && D (extendCME env1 v1) e1 == D (extendCME env2 v2) e2++    go (Let (Rec ps1) e1) (Let (Rec ps2) e2)+      = equalLength ps1 ps2+      && D env1' rs1 == D env2' rs2+      && D env1' e1  == D env2' e2+      where+        (bs1,rs1) = unzip ps1+        (bs2,rs2) = unzip ps2+        env1' = extendCMEs env1 bs1+        env2' = extendCMEs env2 bs2++    go (Case e1 b1 t1 a1) (Case e2 b2 t2 a2)+      | null a1   -- See Note [Empty case alternatives]+      = null a2 && go e1 e2 && D env1 t1 == D env2 t2+      | otherwise+      =  go e1 e2 && D (extendCME env1 b1) a1 == D (extendCME env2 b2) a2++    go _ _ = False++emptyE :: CoreMapX a+emptyE = CM { cm_var = emptyTM, cm_lit = emptyTM+            , cm_co = emptyTM, cm_type = emptyTM+            , cm_cast = emptyTM, cm_app = emptyTM+            , cm_lam = emptyTM, cm_letn = emptyTM+            , cm_letr = emptyTM, cm_case = emptyTM+            , cm_ecase = emptyTM, cm_tick = emptyTM }++instance TrieMap CoreMapX where+   type Key CoreMapX = DeBruijn CoreExpr+   emptyTM  = emptyE+   lookupTM = lkE+   alterTM  = xtE+   foldTM   = fdE+   mapTM    = mapE+   filterTM = ftE++--------------------------+mapE :: (a->b) -> CoreMapX a -> CoreMapX b+mapE f (CM { cm_var = cvar, cm_lit = clit+           , cm_co = cco, cm_type = ctype+           , cm_cast = ccast , cm_app = capp+           , cm_lam = clam, cm_letn = cletn+           , cm_letr = cletr, cm_case = ccase+           , cm_ecase = cecase, cm_tick = ctick })+  = CM { cm_var = mapTM f cvar, cm_lit = mapTM f clit+       , cm_co = mapTM f cco, cm_type = mapTM f ctype+       , cm_cast = mapTM (mapTM f) ccast, cm_app = mapTM (mapTM f) capp+       , cm_lam = mapTM (mapTM f) clam, cm_letn = mapTM (mapTM (mapTM f)) cletn+       , cm_letr = mapTM (mapTM (mapTM f)) cletr, cm_case = mapTM (mapTM f) ccase+       , cm_ecase = mapTM (mapTM f) cecase, cm_tick = mapTM (mapTM f) ctick }++ftE :: (a->Bool) -> CoreMapX a -> CoreMapX a+ftE f (CM { cm_var = cvar, cm_lit = clit+          , cm_co = cco, cm_type = ctype+          , cm_cast = ccast , cm_app = capp+          , cm_lam = clam, cm_letn = cletn+          , cm_letr = cletr, cm_case = ccase+          , cm_ecase = cecase, cm_tick = ctick })+  = CM { cm_var = filterTM f cvar, cm_lit = filterTM f clit+       , cm_co = filterTM f cco, cm_type = filterTM f ctype+       , cm_cast = mapTM (filterTM f) ccast, cm_app = mapTM (filterTM f) capp+       , cm_lam = mapTM (filterTM f) clam, cm_letn = mapTM (mapTM (filterTM f)) cletn+       , cm_letr = mapTM (mapTM (filterTM f)) cletr, cm_case = mapTM (filterTM f) ccase+       , cm_ecase = mapTM (filterTM f) cecase, cm_tick = mapTM (filterTM f) ctick }++--------------------------+lookupCoreMap :: CoreMap a -> CoreExpr -> Maybe a+lookupCoreMap cm e = lookupTM e cm++extendCoreMap :: CoreMap a -> CoreExpr -> a -> CoreMap a+extendCoreMap m e v = alterTM e (\_ -> Just v) m++foldCoreMap :: (a -> b -> b) -> b -> CoreMap a -> b+foldCoreMap k z m = foldTM k m z++emptyCoreMap :: CoreMap a+emptyCoreMap = emptyTM++instance Outputable a => Outputable (CoreMap a) where+  ppr m = text "CoreMap elts" <+> ppr (foldTM (:) m [])++-------------------------+fdE :: (a -> b -> b) -> CoreMapX a -> b -> b+fdE k m+  = foldTM k (cm_var m)+  . foldTM k (cm_lit m)+  . foldTM k (cm_co m)+  . foldTM k (cm_type m)+  . foldTM (foldTM k) (cm_cast m)+  . foldTM (foldTM k) (cm_tick m)+  . foldTM (foldTM k) (cm_app m)+  . foldTM (foldTM k) (cm_lam m)+  . foldTM (foldTM (foldTM k)) (cm_letn m)+  . foldTM (foldTM (foldTM k)) (cm_letr m)+  . foldTM (foldTM k) (cm_case m)+  . foldTM (foldTM k) (cm_ecase m)++-- lkE: lookup in trie for expressions+lkE :: DeBruijn CoreExpr -> CoreMapX a -> Maybe a+lkE (D env expr) cm = go expr cm+  where+    go (Var v)              = cm_var  >.> lkVar env v+    go (Lit l)              = cm_lit  >.> lookupTM l+    go (Type t)             = cm_type >.> lkG (D env t)+    go (Coercion c)         = cm_co   >.> lkG (D env c)+    go (Cast e c)           = cm_cast >.> lkG (D env e) >=> lkG (D env c)+    go (Tick tickish e)     = cm_tick >.> lkG (D env e) >=> lkTickish tickish+    go (App e1 e2)          = cm_app  >.> lkG (D env e2) >=> lkG (D env e1)+    go (Lam v e)            = cm_lam  >.> lkG (D (extendCME env v) e)+                              >=> lkBndr env v+    go (Let (NonRec b r) e) = cm_letn >.> lkG (D env r)+                              >=> lkG (D (extendCME env b) e) >=> lkBndr env b+    go (Let (Rec prs) e)    = let (bndrs,rhss) = unzip prs+                                  env1 = extendCMEs env bndrs+                              in cm_letr+                                 >.> lkList (lkG . D env1) rhss+                                 >=> lkG (D env1 e)+                                 >=> lkList (lkBndr env1) bndrs+    go (Case e b ty as)     -- See Note [Empty case alternatives]+               | null as    = cm_ecase >.> lkG (D env e) >=> lkG (D env ty)+               | otherwise  = cm_case >.> lkG (D env e)+                              >=> lkList (lkA (extendCME env b)) as++xtE :: DeBruijn CoreExpr -> XT a -> CoreMapX a -> CoreMapX a+xtE (D env (Var v))              f m = m { cm_var  = cm_var m+                                                 |> xtVar env v f }+xtE (D env (Type t))             f m = m { cm_type = cm_type m+                                                 |> xtG (D env t) f }+xtE (D env (Coercion c))         f m = m { cm_co   = cm_co m+                                                 |> xtG (D env c) f }+xtE (D _   (Lit l))              f m = m { cm_lit  = cm_lit m  |> alterTM l f }+xtE (D env (Cast e c))           f m = m { cm_cast = cm_cast m |> xtG (D env e)+                                                 |>> xtG (D env c) f }+xtE (D env (Tick t e))           f m = m { cm_tick = cm_tick m |> xtG (D env e)+                                                 |>> xtTickish t f }+xtE (D env (App e1 e2))          f m = m { cm_app = cm_app m |> xtG (D env e2)+                                                 |>> xtG (D env e1) f }+xtE (D env (Lam v e))            f m = m { cm_lam = cm_lam m+                                                 |> xtG (D (extendCME env v) e)+                                                 |>> xtBndr env v f }+xtE (D env (Let (NonRec b r) e)) f m = m { cm_letn = cm_letn m+                                                 |> xtG (D (extendCME env b) e)+                                                 |>> xtG (D env r)+                                                 |>> xtBndr env b f }+xtE (D env (Let (Rec prs) e))    f m = m { cm_letr =+                                              let (bndrs,rhss) = unzip prs+                                                  env1 = extendCMEs env bndrs+                                              in cm_letr m+                                                 |>  xtList (xtG . D env1) rhss+                                                 |>> xtG (D env1 e)+                                                 |>> xtList (xtBndr env1)+                                                            bndrs f }+xtE (D env (Case e b ty as))     f m+                     | null as   = m { cm_ecase = cm_ecase m |> xtG (D env e)+                                                 |>> xtG (D env ty) f }+                     | otherwise = m { cm_case = cm_case m |> xtG (D env e)+                                                 |>> let env1 = extendCME env b+                                                     in xtList (xtA env1) as f }++-- TODO: this seems a bit dodgy, see 'eqTickish'+type TickishMap a = Map.Map (Tickish Id) a+lkTickish :: Tickish Id -> TickishMap a -> Maybe a+lkTickish = lookupTM++xtTickish :: Tickish Id -> XT a -> TickishMap a -> TickishMap a+xtTickish = alterTM++------------------------+data AltMap a   -- A single alternative+  = AM { am_deflt :: CoreMapG a+       , am_data  :: DNameEnv (CoreMapG a)+       , am_lit   :: LiteralMap (CoreMapG a) }++instance TrieMap AltMap where+   type Key AltMap = CoreAlt+   emptyTM  = AM { am_deflt = emptyTM+                 , am_data = emptyDNameEnv+                 , am_lit  = emptyTM }+   lookupTM = lkA emptyCME+   alterTM  = xtA emptyCME+   foldTM   = fdA+   mapTM    = mapA+   filterTM = ftA++instance Eq (DeBruijn CoreAlt) where+  D env1 a1 == D env2 a2 = go a1 a2 where+    go (DEFAULT, _, rhs1) (DEFAULT, _, rhs2)+        = D env1 rhs1 == D env2 rhs2+    go (LitAlt lit1, _, rhs1) (LitAlt lit2, _, rhs2)+        = lit1 == lit2 && D env1 rhs1 == D env2 rhs2+    go (DataAlt dc1, bs1, rhs1) (DataAlt dc2, bs2, rhs2)+        = dc1 == dc2 &&+          D (extendCMEs env1 bs1) rhs1 == D (extendCMEs env2 bs2) rhs2+    go _ _ = False++mapA :: (a->b) -> AltMap a -> AltMap b+mapA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit })+  = AM { am_deflt = mapTM f adeflt+       , am_data = mapTM (mapTM f) adata+       , am_lit = mapTM (mapTM f) alit }++ftA :: (a->Bool) -> AltMap a -> AltMap a+ftA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit })+  = AM { am_deflt = filterTM f adeflt+       , am_data = mapTM (filterTM f) adata+       , am_lit = mapTM (filterTM f) alit }++lkA :: CmEnv -> CoreAlt -> AltMap a -> Maybe a+lkA env (DEFAULT,    _, rhs)  = am_deflt >.> lkG (D env rhs)+lkA env (LitAlt lit, _, rhs)  = am_lit >.> lookupTM lit >=> lkG (D env rhs)+lkA env (DataAlt dc, bs, rhs) = am_data >.> lkDNamed dc+                                        >=> lkG (D (extendCMEs env bs) rhs)++xtA :: CmEnv -> CoreAlt -> XT a -> AltMap a -> AltMap a+xtA env (DEFAULT, _, rhs)    f m =+    m { am_deflt = am_deflt m |> xtG (D env rhs) f }+xtA env (LitAlt l, _, rhs)   f m =+    m { am_lit   = am_lit m   |> alterTM l |>> xtG (D env rhs) f }+xtA env (DataAlt d, bs, rhs) f m =+    m { am_data  = am_data m  |> xtDNamed d+                             |>> xtG (D (extendCMEs env bs) rhs) f }++fdA :: (a -> b -> b) -> AltMap a -> b -> b+fdA k m = foldTM k (am_deflt m)+        . foldTM (foldTM k) (am_data m)+        . foldTM (foldTM k) (am_lit m)

@@ -30,7 +30,7 @@ import GHC.Core import GHC.Utils.Outputable import GHC.Types.Basic-import GHC.Core.Map+import GHC.Core.Map.Expr import GHC.Utils.Misc   ( filterOut, equalLength, debugIsOn ) import GHC.Utils.Panic import Data.List        ( mapAccumL )

@@ -322,7 +322,7 @@     not_strict  = not (isStrUsedDmd (idDemandInfo id))     -- See Note [CPR for sum types]     (_, ret_ty) = splitPiTys (idType id)-    not_a_prod  = isNothing (deepSplitProductType_maybe (ae_fam_envs env) ret_ty)+    not_a_prod  = isNothing (splitArgType_maybe (ae_fam_envs env) ret_ty)     returns_sum = not (isTopLevel top_lvl) && not_a_prod  isDataStructure :: Id -> CoreExpr -> Bool@@ -425,7 +425,7 @@ extendSigEnvForDemand :: AnalEnv -> Id -> Demand -> AnalEnv extendSigEnvForDemand env id dmd   | isId id-  , Just (_, DataConAppContext { dcac_dc = dc })+  , Just (_, DataConPatContext { dcpc_dc = dc })       <- wantToUnbox (ae_fam_envs env) has_inlineable_prag (idType id) dmd   = extendSigEnv env id (CprSig (conCprType (dataConTag dc)))   | otherwise@@ -446,14 +446,12 @@      ids_w_strs    = filter isId bndrs `zip` dataConRepStrictness dc -    tycon          = dataConTyCon dc-    is_product     = isJust (isDataProductTyCon_maybe tycon)-    is_sum         = isJust (isDataSumTyCon_maybe tycon)+    is_algebraic   = isJust (tyConAlgDataCons_maybe (dataConTyCon dc))+    no_exs         = null (dataConExTyCoVars dc)     case_bndr_ty-      | is_product || is_sum = conCprType  (dataConTag dc)-      -- Any of the constructors had existentials. This is a little too-      -- conservative (after all, we only care about the particular data con),-      -- but there is no easy way to write is_sum and this won't happen much.+      | is_algebraic, no_exs = conCprType (dataConTag dc)+      -- The tycon wasn't algebraic or the datacon had existentials.+      -- See Note [Which types are unboxed?] for why no existentials.       | otherwise            = topCprType      -- We could have much deeper CPR info here with Nested CPR, which could

@@ -34,9 +34,10 @@ import GHC.Core.Utils import GHC.Core.TyCon import GHC.Core.Type-import GHC.Core.FVs      ( exprFreeIds, ruleRhsFreeIds )+import GHC.Core.FVs      ( rulesRhsFreeIds, bndrRuleAndUnfoldingIds ) import GHC.Core.Coercion ( Coercion, coVarsOfCo ) import GHC.Core.FamInstEnv+import GHC.Core.Opt.Arity ( typeArity ) import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Data.Maybe         ( isJust )@@ -64,29 +65,56 @@ -- -- Note: use `seqBinds` on the result to avoid leaks due to lazyness (cf Note -- [Stamp out space leaks in demand analysis])-dmdAnalProgram :: DmdAnalOpts -> FamInstEnvs -> CoreProgram -> CoreProgram-dmdAnalProgram opts fam_envs binds = binds_plus_dmds-   where-      env             = emptyAnalEnv opts fam_envs-      binds_plus_dmds = snd $ mapAccumL dmdAnalTopBind env binds---- Analyse a (group of) top-level binding(s)-dmdAnalTopBind :: AnalEnv-               -> CoreBind-               -> (AnalEnv, CoreBind)-dmdAnalTopBind env (NonRec id rhs)-  = ( extendAnalEnv TopLevel env id sig-    , NonRec (setIdStrictness id sig) rhs')+dmdAnalProgram :: DmdAnalOpts -> FamInstEnvs -> [CoreRule] -> CoreProgram -> CoreProgram+dmdAnalProgram opts fam_envs rules binds+  = snd $ go (emptyAnalEnv opts fam_envs) binds   where-    ( _, sig, rhs') = dmdAnalRhsLetDown Nothing env topSubDmd id rhs+    -- See Note [Analysing top-level bindings]+    -- and Note [Why care for top-level demand annotations?]+    go _   []     = (nopDmdType, [])+    go env (b:bs) = cons_up $ dmdAnalBind TopLevel env topSubDmd b anal_body+      where+        anal_body env'+          | (body_ty, bs') <- go env' bs+          = (add_exported_uses env' body_ty (bindersOf b), bs') -dmdAnalTopBind env (Rec pairs)-  = (env', Rec pairs')-  where-    (env', _, pairs')  = dmdFix TopLevel env topSubDmd pairs-                -- We get two iterations automatically-                -- c.f. the NonRec case above+    cons_up :: (a, b, [b]) -> (a, [b])+    cons_up (dmd_ty, b', bs') = (dmd_ty, b':bs') +    add_exported_uses :: AnalEnv -> DmdType -> [Id] -> DmdType+    add_exported_uses env = foldl' (add_exported_use env)++    -- | If @e@ is denoted by @dmd_ty@, then @add_exported_use _ dmd_ty id@+    -- corresponds to the demand type of @(id, e)@, but is a lot more direct.+    -- See Note [Analysing top-level bindings].+    add_exported_use :: AnalEnv -> DmdType -> Id -> DmdType+    add_exported_use env dmd_ty id+      | isExportedId id || elemVarSet id rule_fvs+      -- See Note [Absence analysis for stable unfoldings and RULES]+      = dmd_ty `plusDmdType` fst (dmdAnalStar env topDmd (Var id))+      | otherwise+      = dmd_ty++    rule_fvs :: IdSet+    rule_fvs = rulesRhsFreeIds rules++-- | We attach useful (e.g. not 'topDmd') 'idDemandInfo' to top-level bindings+-- that satisfy this function.+--+-- Basically, we want to know how top-level *functions* are *used*+-- (e.g. called). The information will always be lazy.+-- Any other top-level bindings are boring.+--+-- See also Note [Why care for top-level demand annotations?].+isInterestingTopLevelFn :: Id -> Bool+-- SG tried to set this to True and got a +2% ghc/alloc regression in T5642+-- (which is dominated by the Simplifier) at no gain in analysis precision.+-- If there was a gain, that regression might be acceptable.+-- Plus, we could use LetUp for thunks and share some code with local let+-- bindings.+isInterestingTopLevelFn id =+  typeArity (idType id) `lengthExceeds` 0+ {- Note [Stamp out space leaks in demand analysis] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The demand analysis pass outputs a new copy of the Core program in@@ -105,16 +133,187 @@ unforced thunks in demand or strictness information; and it is the most memory-intensive part of the compilation process, so this added seqBinds makes a big difference in peak memory usage.--} +Note [Analysing top-level bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a CoreProgram like+  e1 = ...+  n1 = ...+  e2 = \a b -> ... fst (n1 a b) ...+  n2 = \c d -> ... snd (e2 c d) ...+  ...+where e* are exported, but n* are not.+Intuitively, we can see that @n1@ is only ever called with two arguments+and in every call site, the first component of the result of the call+is evaluated. Thus, we'd like it to have idDemandInfo @UCU(C1(P(SU,A))@.+NB: We may *not* give e2 a similar annotation, because it is exported and+external callers might use it in arbitrary ways, expressed by 'topDmd'.+This can then be exploited by Nested CPR and eta-expansion,+see Note [Why care for top-level demand annotations?]. +How do we get this result? Answer: By analysing the program as if it was a let+expression of this form:+  let e1 = ... in+  let n1 = ... in+  let e2 = ... in+  let n2 = ... in+  (e1,e2, ...)+E.g. putting all bindings in nested lets and returning all exported binders in a tuple.+Of course, we will not actually build that CoreExpr! Instead we faithfully+simulate analysis of said expression by adding the free variable 'DmdEnv'+of @e*@'s strictness signatures to the 'DmdType' we get from analysing the+nested bindings.++And even then the above form blows up analysis performance in T10370:+If @e1@ uses many free variables, we'll unnecessarily carry their demands around+with us from the moment we analyse the pair to the moment we bubble back up to+the binding for @e1@. So instead we analyse as if we had+  let e1 = ... in+  (e1, let n1 = ... in+  (    let e2 = ... in+  (e2, let n2 = ... in+  (    ...))))+That is, a series of right-nested pairs, where the @fst@ are the exported+binders of the last enclosing let binding and @snd@ continues the nested+lets.++Variables occuring free in RULE RHSs are to be handled the same as exported Ids.+See also Note [Absence analysis for stable unfoldings and RULES].++Note [Why care for top-level demand annotations?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Reading Note [Analysing top-level bindings], you might think that we go through+quite some trouble to get useful demands for top-level bindings. They can never+be strict, for example, so why bother?++First, we get to eta-expand top-level bindings that we weren't able to+eta-expand before without Call Arity. From T18894b:+  module T18894b (f) where+  eta :: Int -> Int -> Int+  eta x = if fst (expensive x) == 13 then \y -> ... else \y -> ...+  f m = ... eta m 2 ... eta 2 m ...+Since only @f@ is exported, we see all call sites of @eta@ and can eta-expand to+arity 2.++The call demands we get for some top-level bindings will also allow Nested CPR+to unbox deeper. From T18894:+  module T18894 (h) where+  g m n = (2 * m, 2 `div` n)+  {-# NOINLINE g #-}+  h :: Int -> Int+  h m = ... snd (g m 2) ... uncurry (+) (g 2 m) ...+Only @h@ is exported, hence we see that @g@ is always called in contexts were we+also force the division in the second component of the pair returned by @g@.+This allows Nested CPR to evalute the division eagerly and return an I# in its+position.+-}+ {- ************************************************************************ *                                                                      * \subsection{The analyser itself} *                                                                      * ************************************************************************+-} +-- | Analyse a binding group and its \"body\", e.g. where it is in scope.+--+-- It calls a function that knows how to analyse this \"body\" given+-- an 'AnalEnv' with updated demand signatures for the binding group+-- (reflecting their 'idStrictnessInfo') and expects to receive a+-- 'DmdType' in return, which it uses to annotate the binding group with their+-- 'idDemandInfo'.+dmdAnalBind+  :: TopLevelFlag+  -> AnalEnv+  -> SubDemand                 -- ^ Demand put on the "body"+                               --   (important for join points)+  -> CoreBind+  -> (AnalEnv -> (DmdType, a)) -- ^ How to analyse the "body", e.g.+                               --   where the binding is in scope+  -> (DmdType, CoreBind, a)+dmdAnalBind top_lvl env dmd bind anal_body = case bind of+  NonRec id rhs+    | useLetUp top_lvl id+    -> dmdAnalBindLetUp   top_lvl env     id rhs anal_body+  _ -> dmdAnalBindLetDown top_lvl env dmd bind   anal_body++-- | Annotates uninteresting top level functions ('isInterestingTopLevelFn')+-- with 'topDmd', the rest with the given demand.+setBindIdDemandInfo :: TopLevelFlag -> Id -> Demand -> Id+setBindIdDemandInfo top_lvl id dmd = setIdDemandInfo id $ case top_lvl of+  TopLevel | not (isInterestingTopLevelFn id) -> topDmd+  _                                           -> dmd++-- | Let bindings can be processed in two ways:+-- Down (RHS before body) or Up (body before RHS).+-- This function handles the up variant.+--+-- It is very simple. For  let x = rhs in body+--   * Demand-analyse 'body' in the current environment+--   * Find the demand, 'rhs_dmd' placed on 'x' by 'body'+--   * Demand-analyse 'rhs' in 'rhs_dmd'+--+-- This is used for a non-recursive local let without manifest lambdas (see+-- 'useLetUp').+--+-- This is the LetUp rule in the paper “Higher-Order Cardinality Analysis”.+dmdAnalBindLetUp :: TopLevelFlag -> AnalEnv -> Id -> CoreExpr -> (AnalEnv -> (DmdType, a)) -> (DmdType, CoreBind, a)+dmdAnalBindLetUp top_lvl env id rhs anal_body = (final_ty, NonRec id' rhs', body')+  where+    (body_ty, body')   = anal_body env+    (body_ty', id_dmd) = findBndrDmd env notArgOfDfun body_ty id+    id'                = setBindIdDemandInfo top_lvl id id_dmd+    (rhs_ty, rhs')     = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd) rhs++    -- See Note [Absence analysis for stable unfoldings and RULES]+    rule_fvs           = bndrRuleAndUnfoldingIds id+    final_ty           = body_ty' `plusDmdType` rhs_ty `keepAliveDmdType` rule_fvs++-- | Let bindings can be processed in two ways:+-- Down (RHS before body) or Up (body before RHS).+-- This function handles the down variant.+--+-- It computes a demand signature (by means of 'dmdAnalRhsSig') and uses+-- that at call sites in the body.+--+-- It is used for toplevel definitions, recursive definitions and local+-- non-recursive definitions that have manifest lambdas (cf. 'useLetUp').+-- Local non-recursive definitions without a lambda are handled with LetUp.+--+-- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”.+dmdAnalBindLetDown :: TopLevelFlag -> AnalEnv -> SubDemand -> CoreBind -> (AnalEnv -> (DmdType, a)) -> (DmdType, CoreBind, a)+dmdAnalBindLetDown top_lvl env dmd bind anal_body = case bind of+  NonRec id rhs+    | (env', lazy_fv, id1, rhs1) <-+        dmdAnalRhsSig top_lvl NonRecursive env dmd id rhs+    -> do_rest env' lazy_fv [(id1, rhs1)] (uncurry NonRec . only)+  Rec pairs+    | (env', lazy_fv, pairs') <- dmdFix top_lvl env dmd pairs+    -> do_rest env' lazy_fv pairs' Rec+  where+    do_rest env' lazy_fv pairs1 build_bind = (final_ty, build_bind pairs2, body')+      where+        (body_ty, body')        = anal_body env'+        -- see Note [Lazy and unleashable free variables]+        dmd_ty                  = addLazyFVs body_ty lazy_fv+        (!final_ty, id_dmds)    = findBndrsDmds env' dmd_ty (map fst pairs1)+        pairs2                  = zipWith do_one pairs1 id_dmds+        do_one (id', rhs') dmd  = (setBindIdDemandInfo top_lvl id' dmd, rhs')+        -- If the actual demand is better than the vanilla call+        -- demand, you might think that we might do better to re-analyse+        -- the RHS with the stronger demand.+        -- But (a) That seldom happens, because it means that *every* path in+        --         the body of the let has to use that stronger demand+        -- (b) It often happens temporarily in when fixpointing, because+        --     the recursive function at first seems to place a massive demand.+        --     But we don't want to go to extra work when the function will+        --     probably iterate to something less demanding.+        -- In practice, all the times the actual demand on id2 is more than+        -- the vanilla call demand seem to be due to (b).  So we don't+        -- bother to re-analyse the RHS.++{- Note [Ensure demand is strict] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It's important not to analyse e with a lazy demand because@@ -194,7 +393,7 @@     -- Crucially, coercions /are/ handled here, because they are     -- value arguments (#10288)     let-        call_dmd          = mkCallDmd dmd+        call_dmd          = mkCalledOnceDmd dmd         (fun_ty, fun')    = dmdAnal env call_dmd fun         (arg_dmd, res_ty) = splitDmdTy fun_ty         (arg_ty, arg')    = dmdAnalStar env (dmdTransformThunkDmd arg arg_dmd) arg@@ -227,8 +426,8 @@  dmdAnal' env dmd (Case scrut case_bndr ty [(alt, bndrs, rhs)])   -- Only one alternative.-  -- If it's a DataAlt, it should be a product constructor.-  | is_non_sum_alt alt+  -- If it's a DataAlt, it should be the only constructor of the type.+  | is_single_data_alt alt   = let         (rhs_ty, rhs')           = dmdAnal env dmd rhs         (alt_ty1, dmds)          = findBndrsDmds env rhs_ty bndrs@@ -267,8 +466,8 @@ --                                   , text "res_ty" <+> ppr res_ty ]) $     (res_ty, Case scrut' case_bndr' ty [(alt, bndrs', rhs')])     where-      is_non_sum_alt (DataAlt dc) = isJust $ isDataProductTyCon_maybe $ dataConTyCon dc-      is_non_sum_alt _            = True+      is_single_data_alt (DataAlt dc) = isJust $ tyConSingleAlgDataCon_maybe $ dataConTyCon dc+      is_single_data_alt _            = True  dmdAnal' env dmd (Case scrut case_bndr ty alts)   = let      -- Case expression with multiple alternatives@@ -295,60 +494,11 @@ --                                   , text "res_ty" <+> ppr res_ty ]) $     (res_ty, Case scrut' case_bndr' ty alts') --- Let bindings can be processed in two ways:--- Down (RHS before body) or Up (body before RHS).--- The following case handle the up variant.------ It is very simple. For  let x = rhs in body---   * Demand-analyse 'body' in the current environment---   * Find the demand, 'rhs_dmd' placed on 'x' by 'body'---   * Demand-analyse 'rhs' in 'rhs_dmd'------ This is used for a non-recursive local let without manifest lambdas.--- This is the LetUp rule in the paper “Higher-Order Cardinality Analysis”.-dmdAnal' env dmd (Let (NonRec id rhs) body)-  | useLetUp id-  = (final_ty, Let (NonRec id' rhs') body')-  where-    (body_ty, body')   = dmdAnal env dmd body-    (body_ty', id_dmd) = findBndrDmd env notArgOfDfun body_ty id-    id'                = setIdDemandInfo id id_dmd--    (rhs_ty, rhs')     = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd) rhs-    final_ty           = body_ty' `plusDmdType` rhs_ty--dmdAnal' env dmd (Let (NonRec id rhs) body)-  = (body_ty2, Let (NonRec id2 rhs') body')+dmdAnal' env dmd (Let bind body)+  = (final_ty, Let bind' body')   where-    (lazy_fv, sig, rhs') = dmdAnalRhsLetDown Nothing env dmd id rhs-    id1                  = setIdStrictness id sig-    env1                 = extendAnalEnv NotTopLevel env id sig-    (body_ty, body')     = dmdAnal env1 dmd body-    (body_ty1, id2)      = annotateBndr env body_ty id1-    body_ty2             = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleashable free variables]--        -- If the actual demand is better than the vanilla call-        -- demand, you might think that we might do better to re-analyse-        -- the RHS with the stronger demand.-        -- But (a) That seldom happens, because it means that *every* path in-        --         the body of the let has to use that stronger demand-        -- (b) It often happens temporarily in when fixpointing, because-        --     the recursive function at first seems to place a massive demand.-        --     But we don't want to go to extra work when the function will-        --     probably iterate to something less demanding.-        -- In practice, all the times the actual demand on id2 is more than-        -- the vanilla call demand seem to be due to (b).  So we don't-        -- bother to re-analyse the RHS.--dmdAnal' env dmd (Let (Rec pairs) body)-  = let-        (env', lazy_fv, pairs') = dmdFix NotTopLevel env dmd pairs-        (body_ty, body')        = dmdAnal env' dmd body-        body_ty1                = deleteFVs body_ty (map fst pairs)-        body_ty2                = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleashable free variables]-    in-    body_ty2 `seq`-    (body_ty2,  Let (Rec pairs') body')+    (final_ty, bind', body') = dmdAnalBind NotTopLevel env dmd bind go'+    go' env'                 = dmdAnal env' dmd body  -- | A simple, syntactic analysis of whether an expression MAY throw a precise -- exception when evaluated. It's always sound to return 'True'.@@ -377,10 +527,11 @@ forcesRealWorld fam_envs ty   | ty `eqType` realWorldStatePrimTy   = True-  | Just DataConAppContext{ dcac_dc = dc, dcac_arg_tys = field_tys }-      <- deepSplitProductType_maybe fam_envs ty+  | Just DataConPatContext{ dcpc_dc = dc, dcpc_tc_args = tc_args }+      <- splitArgType_maybe fam_envs ty   , isUnboxedTupleDataCon dc-  = any (\(ty,_) -> scaledThing ty `eqType` realWorldStatePrimTy) field_tys+  , let field_tys = dataConInstArgTys dc tc_args+  = any (eqType realWorldStatePrimTy . scaledThing) field_tys   | otherwise   = False @@ -582,9 +733,17 @@   | Just (sig, top_lvl) <- lookupSigEnv env var   , let fn_ty = dmdTransformSig sig dmd   = -- pprTrace "dmdTransform:LetDown" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $-    if isTopLevel top_lvl-    then fn_ty   -- Don't record demand on top-level things-    else addVarDmd fn_ty var (C_11 :* dmd)+    case top_lvl of+      NotTopLevel -> addVarDmd fn_ty var (C_11 :* dmd)+      TopLevel+        | isInterestingTopLevelFn var+        -- Top-level things will be used multiple times or not at+        -- all anyway, hence the multDmd below: It means we don't+        -- have to track whether @var@ is used strictly or at most+        -- once, because ultimately it never will.+        -> addVarDmd fn_ty var (C_0N `multDmd` (C_11 :* dmd)) -- discard strictness+        | otherwise+        -> fn_ty -- don't bother tracking; just annotate with 'topDmd' later   -- Everything else:   --   * Local let binders for which we use LetUp (cf. 'useLetUp')   --   * Lambda binders@@ -599,46 +758,46 @@ *                                                                      * ********************************************************************* -} --- Let bindings can be processed in two ways:--- Down (RHS before body) or Up (body before RHS).--- dmdAnalRhsLetDown implements the Down variant:---  * assuming a demand of <L,U>+-- | @dmdAnalRhsSig@ analyses the given RHS to compute a demand signature+-- for the LetDown rule. It works as follows:+--+--  * assuming a demand of <U> --  * looking at the definition --  * determining a strictness signature ----- It is used for toplevel definition, recursive definitions and local--- non-recursive definitions that have manifest lambdas.--- Local non-recursive definitions without a lambda are handled with LetUp.------ This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”.-dmdAnalRhsLetDown-  :: Maybe [Id]   -- Just bs <=> recursive, Nothing <=> non-recursive+-- Since it assumed a demand of <U>, the resulting signature is applicable at+-- any call site.+dmdAnalRhsSig+  :: TopLevelFlag+  -> RecFlag   -> AnalEnv -> SubDemand   -> Id -> CoreExpr-  -> (DmdEnv, StrictSig, CoreExpr)+  -> (AnalEnv, DmdEnv, Id, CoreExpr) -- Process the RHS of the binding, add the strictness signature -- to the Id, and augment the environment with the signature as well. -- See Note [NOINLINE and strictness]-dmdAnalRhsLetDown rec_flag env let_dmd id rhs-  = -- pprTrace "dmdAnalRhsLetDown" (ppr id $$ ppr let_dmd $$ ppr sig $$ ppr lazy_fv) $-    (lazy_fv, sig, rhs')+dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs+  = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr sig $$ ppr lazy_fv) $+    (env', lazy_fv, id', rhs')   where     rhs_arity = idArity id+    -- See Note [Demand signatures are computed for a threshold demand based on idArity]     rhs_dmd -- See Note [Demand analysis for join points]             -- See Note [Invariants on join points] invariant 2b, in GHC.Core             --     rhs_arity matches the join arity of the join point             | isJoinId id-            = mkCallDmds rhs_arity let_dmd+            = mkCalledOnceDmds rhs_arity let_dmd             | otherwise-            -- NB: rhs_arity-            -- See Note [Demand signatures are computed for a threshold demand based on idArity]-            = mkRhsDmd env rhs_arity rhs+            = mkCalledOnceDmds rhs_arity topSubDmd      (rhs_dmd_ty, rhs') = dmdAnal env rhs_dmd rhs     DmdType rhs_fv rhs_dmds rhs_div = rhs_dmd_ty      sig = mkStrictSigForArity rhs_arity (DmdType sig_fv rhs_dmds rhs_div) +    id' = id `setIdStrictness` sig+    env' = extendAnalEnv top_lvl env id' sig+     -- See Note [Aggregated demand for cardinality]     -- FIXME: That Note doesn't explain the following lines at all. The reason     --        is really much different: When we have a recursive function, we'd@@ -651,31 +810,15 @@     --        we'd have to do an additional iteration. reuseEnv makes sure that     --        we never get used-once info for FVs of recursive functions.     rhs_fv1 = case rec_flag of-                Just bs -> reuseEnv (delVarEnvList rhs_fv bs)-                Nothing -> rhs_fv+                Recursive    -> reuseEnv rhs_fv+                NonRecursive -> rhs_fv -    rhs_fv2 = rhs_fv1 `keepAliveDmdEnv` extra_fvs-    -- Find the RHS free vars of the unfoldings and RULES     -- See Note [Absence analysis for stable unfoldings and RULES]-    extra_fvs = foldr (unionVarSet . ruleRhsFreeIds) unf_fvs $-                idCoreRules id+    rhs_fv2 = rhs_fv1 `keepAliveDmdEnv` bndrRuleAndUnfoldingIds id      -- See Note [Lazy and unleashable free variables]     (lazy_fv, sig_fv) = partitionVarEnv isWeakDmd rhs_fv2 -    unf = realIdUnfolding id-    unf_fvs | isStableUnfolding unf-            , Just unf_body <- maybeUnfoldingTemplate unf-            = exprFreeIds unf_body-            | otherwise = emptyVarSet---- | @mkRhsDmd env rhs_arity rhs@ creates a 'SubDemand' for--- unleashing on the given function's @rhs@, by creating--- a call demand of @rhs_arity@--- See Historical Note [Product demands for function body]-mkRhsDmd :: AnalEnv -> Arity -> CoreExpr -> SubDemand-mkRhsDmd _env rhs_arity _rhs = mkCallDmds rhs_arity topSubDmd- -- | If given the (local, non-recursive) let-bound 'Id', 'useLetUp' determines -- whether we should process the binding up (body before rhs) or down (rhs -- before body).@@ -720,8 +863,8 @@ --   * For a more convincing example with join points, see Note [Demand analysis --     for join points]. ---useLetUp :: Var -> Bool-useLetUp f = idArity f == 0 && not (isJoinId f)+useLetUp :: TopLevelFlag -> Var -> Bool+useLetUp top_lvl f = isNotTopLevel top_lvl && idArity f == 0 && not (isJoinId f)  {- Note [Demand analysis for join points] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -939,8 +1082,6 @@ dmdFix top_lvl env let_dmd orig_pairs   = loop 1 initial_pairs   where-    bndrs = map fst orig_pairs-     -- See Note [Initialising strictness]     initial_pairs | ae_virgin env = [(setIdStrictness id botSig, rhs) | (id, rhs) <- orig_pairs ]                   | otherwise     = orig_pairs@@ -990,10 +1131,8 @@           = -- pprTrace "my_downRhs" (ppr id $$ ppr (idStrictness id) $$ ppr sig) $             ((env', lazy_fv'), (id', rhs'))           where-            (lazy_fv1, sig, rhs') = dmdAnalRhsLetDown (Just bndrs) env let_dmd id rhs-            lazy_fv'              = plusVarEnv_C plusDmd lazy_fv lazy_fv1-            env'                  = extendAnalEnv top_lvl env id sig-            id'                   = setIdStrictness id sig+            (env', lazy_fv1, id', rhs') = dmdAnalRhsSig top_lvl Recursive env let_dmd id rhs+            lazy_fv'                    = plusVarEnv_C plusDmd lazy_fv lazy_fv1      zapIdStrictness :: [(Id, CoreExpr)] -> [(Id, CoreExpr)]     zapIdStrictness pairs = [(setIdStrictness id nopSig, rhs) | (id, rhs) <- pairs ]@@ -1090,7 +1229,7 @@         -- demand with the bottom coming up from 'error'         --         -- I got a loop in the fixpointer without this, due to an interaction-        -- with the lazy_fv filtering in dmdAnalRhsLetDown.  Roughly, it was+        -- with the lazy_fv filtering in dmdAnalRhsSig.  Roughly, it was         --      letrec f n x         --          = letrec g y = x `fatbar`         --                         letrec h z = z + ...g...@@ -1155,10 +1294,6 @@      main_ty = addDemand dmd dmd_ty'     (dmd_ty', dmd) = findBndrDmd env arg_of_dfun dmd_ty id--deleteFVs :: DmdType -> [Var] -> DmdType-deleteFVs (DmdType fvs dmds res) bndrs-  = DmdType (delVarEnvList fvs bndrs) dmds res  {- Note [NOINLINE and strictness]

@@ -66,6 +66,7 @@ import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Basic+import GHC.Types.Demand ( zapDmdEnvSig ) import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Unique.Supply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )@@ -109,10 +110,7 @@     dflags         = hsc_dflags hsc_env     home_pkg_rules = hptRules hsc_env (dep_mods deps)     hpt_rule_base  = mkRuleBase home_pkg_rules-    print_unqual   = mkPrintUnqualified-                        (unitState dflags)-                        (hsc_home_unit hsc_env)-                        rdr_env+    print_unqual   = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env     -- mod: get the module out of the current HscEnv so we can retrieve it from the monad.     -- This is very convienent for the users of the monad (e.g. plugins do not have to     -- consume the ModGuts to find the module) but somewhat ugly because mg_module may@@ -499,7 +497,7 @@                                        doPass exitifyProgram  doCorePass CoreDoDemand              = {-# SCC "DmdAnal" #-}-                                       doPassDFM dmdAnal+                                       doPassDFRM dmdAnal  doCorePass CoreDoCpr                 = {-# SCC "CprAnal" #-}                                        doPassDFM cprAnalProgram@@ -582,6 +580,13 @@     let fam_envs = (p_fam_env, mg_fam_inst_env guts)     doPassM (liftIO . do_pass dflags fam_envs) guts +doPassDFRM :: (DynFlags -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts+doPassDFRM do_pass guts = do+    dflags <- getDynFlags+    p_fam_env <- getPackageFamInstEnv+    let fam_envs = (p_fam_env, mg_fam_inst_env guts)+    doPassM (liftIO . do_pass dflags fam_envs (mg_rules guts)) guts+ doPassDFU :: (DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts doPassDFU do_pass guts = do     dflags <- getDynFlags@@ -714,7 +719,7 @@     }   where     dflags       = hsc_dflags hsc_env-    print_unqual = mkPrintUnqualified (unitState dflags) (hsc_home_unit hsc_env) rdr_env+    print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env     simpl_env    = mkSimplEnv mode     active_rule  = activeRule mode     active_unf   = activeUnfolding mode@@ -1095,13 +1100,13 @@   -dmdAnal :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram-dmdAnal dflags fam_envs binds = do+dmdAnal :: DynFlags -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram+dmdAnal dflags fam_envs rules binds = do   let opts = DmdAnalOpts                { dmd_strict_dicts = gopt Opt_DictsStrict dflags                }-      binds_plus_dmds = dmdAnalProgram opts fam_envs binds+      binds_plus_dmds = dmdAnalProgram opts fam_envs rules binds   Err.dumpIfSet_dyn dflags Opt_D_dump_str_signatures "Strictness signatures" FormatText $-    dumpIdInfoOfProgram (ppr . strictnessInfo) binds_plus_dmds+    dumpIdInfoOfProgram (ppr . zapDmdEnvSig . strictnessInfo) binds_plus_dmds   -- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal   seqBinds binds_plus_dmds `seq` return binds_plus_dmds

@@ -2182,7 +2182,8 @@           [ text "Rule:" <+> ftext (ruleName rule)           , text "Module:" <+>  printRuleModule rule           , text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args))-          , text "After: " <+> pprCoreExpr rule_rhs+          , text "After: " <+> hang (pprCoreExpr rule_rhs) 2+                               (sep $ map ppr $ drop (ruleArity rule) args)           , text "Cont:  " <+> ppr call_cont ]        | dopt Opt_D_dump_rule_firings dflags

@@ -598,11 +598,10 @@ mkRecFloats :: SimplFloats -> SimplFloats -- Flattens the floats into a single Rec group, -- They must either all be lifted LetFloats or all JoinFloats-mkRecFloats floats@(SimplFloats { sfLetFloats  = LetFloats bs ff+mkRecFloats floats@(SimplFloats { sfLetFloats  = LetFloats bs _ff                                 , sfJoinFloats = jbs                                 , sfInScope    = in_scope })-  = ASSERT2( case ff of { FltLifted -> True; _ -> False }, ppr (fromOL bs) )-    ASSERT2( isNilOL bs || isNilOL jbs, ppr floats )+  = ASSERT2( isNilOL bs || isNilOL jbs, ppr floats )     SimplFloats { sfLetFloats  = floats'                 , sfJoinFloats = jfloats'                 , sfInScope    = in_scope }

@@ -484,7 +484,7 @@   | is_fun && is_eta_exp   = splitFun dflags fam_envs new_fn_id fn_info wrap_dmds div cpr rhs -  | is_thunk                                   -- See Note [Thunk splitting]+  | isNonRec is_rec, is_thunk                        -- See Note [Thunk splitting]   = splitThunk dflags fam_envs is_rec new_fn_id rhs    | otherwise@@ -777,6 +777,10 @@ In fact, splitThunk uses the function argument w/w splitting function, so that if x's demand is deeper (say U(U(L,L),L)) then the splitting will go deeper too.++NB: For recursive thunks, the Simplifier is unable to float `x-rhs` out of+`x*`'s RHS, because `x*` occurs freely in `x-rhs`, and will just change it+back to the original definition, so we just split non-recursive thunks. -}  -- See Note [Thunk splitting]

@@ -8,7 +8,7 @@  module GHC.Core.Opt.WorkWrap.Utils    ( mkWwBodies, mkWWstr, mkWorkerArgs-   , DataConAppContext(..), deepSplitProductType_maybe, wantToUnbox+   , DataConPatContext(..), splitArgType_maybe, wantToUnbox    , findTypeShape    , isWorkerSmallEnough    )@@ -19,7 +19,8 @@ import GHC.Prelude  import GHC.Core-import GHC.Core.Utils   ( exprType, mkCast, mkDefaultCase, mkSingleAltCase )+import GHC.Core.Utils   ( exprType, mkCast, mkDefaultCase, mkSingleAltCase+                        , dataConRepFSInstPat ) import GHC.Types.Id import GHC.Types.Id.Info ( JoinArity ) import GHC.Core.DataCon@@ -43,9 +44,11 @@ import GHC.Core.TyCon.RecWalk import GHC.Types.Unique.Supply import GHC.Types.Unique+import GHC.Types.Name ( getOccFS ) import GHC.Data.Maybe import GHC.Utils.Misc import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Driver.Session import GHC.Driver.Ppr import GHC.Data.FastString@@ -606,53 +609,53 @@     arg_ty = idType arg     dmd    = idDemandInfo arg -wantToUnbox :: FamInstEnvs -> Bool -> Type -> Demand -> Maybe ([Demand], DataConAppContext)+wantToUnbox :: FamInstEnvs -> Bool -> Type -> Demand -> Maybe ([Demand], DataConPatContext)+-- See Note [Which types are unboxed?] wantToUnbox fam_envs has_inlineable_prag ty dmd =-  case deepSplitProductType_maybe fam_envs ty of-    Just dcac@DataConAppContext{ dcac_arg_tys = con_arg_tys }+  case splitArgType_maybe fam_envs ty of+    Just dcpc@DataConPatContext{ dcpc_dc = dc }       | isStrUsedDmd dmd+      , let arity = dataConRepArity dc       -- See Note [Unpacking arguments with product and polymorphic demands]-      , Just cs <- split_prod_dmd_arity dmd (length con_arg_tys)+      , Just cs <- split_prod_dmd_arity dmd arity       -- See Note [Do not unpack class dictionaries]       , not (has_inlineable_prag && isClassPred ty)       -- See Note [mkWWstr and unsafeCoerce]-      , cs `equalLength` con_arg_tys-      -> Just (cs, dcac)+      , cs `lengthIs` arity+      -> Just (cs, dcpc)     _ -> Nothing   where-    split_prod_dmd_arity dmd arty+    split_prod_dmd_arity dmd arity       -- For seqDmd, it should behave like <S(AAAA)>, for some       -- suitable arity-      | isSeqDmd dmd        = Just (replicate arty absDmd)+      | isSeqDmd dmd        = Just (replicate arity absDmd)       | _ :* Prod ds <- dmd = Just ds       | otherwise           = Nothing  unbox_one :: DynFlags -> FamInstEnvs -> Var           -> [Demand]-          -> DataConAppContext+          -> DataConPatContext           -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) unbox_one dflags fam_envs arg cs-          DataConAppContext { dcac_dc = data_con, dcac_tys = inst_tys-                            , dcac_arg_tys = inst_con_arg_tys-                            , dcac_co = co }-  = do { (uniq1:uniqs) <- getUniquesM-        ; let   scale = scaleScaled (idMult arg)-                scaled_inst_con_arg_tys = map (\(t,s) -> (scale t, s)) inst_con_arg_tys-                -- See Note [Add demands for strict constructors]-                cs'       = addDataConStrictness data_con cs-                unpk_args = zipWith3 mk_ww_arg uniqs scaled_inst_con_arg_tys cs'-                unbox_fn  = mkUnpackCase (Var arg) co (idMult arg) uniq1-                                         data_con unpk_args-                arg_no_unf = zapStableUnfolding arg-                             -- See Note [Zap unfolding when beta-reducing]-                             -- in GHC.Core.Opt.Simplify; and see #13890-                rebox_fn   = Let (NonRec arg_no_unf con_app)-                con_app    = mkConApp2 data_con inst_tys unpk_args `mkCast` mkSymCo co-         ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False unpk_args-         ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) }-                           -- Don't pass the arg, rebox instead-  where-    mk_ww_arg uniq ty sub_dmd = setIdDemandInfo (mk_ww_local uniq ty) sub_dmd+          DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args+                            , dcpc_co = co }+  = do { (case_bndr_uniq:pat_bndrs_uniqs) <- getUniquesM+       ; let ex_name_fss     = map getOccFS $ dataConExTyCoVars dc+             (ex_tvs', arg_ids) =+               dataConRepFSInstPat (ex_name_fss ++ repeat ww_prefix) pat_bndrs_uniqs (idMult arg) dc tc_args+             -- See Note [Add demands for strict constructors]+             cs'       = addDataConStrictness dc cs+             arg_ids'  = zipWithEqual "unbox_one" setIdDemandInfo arg_ids cs'+             unbox_fn  = mkUnpackCase (Var arg) co (idMult arg) case_bndr_uniq+                                      dc (ex_tvs' ++ arg_ids')+             arg_no_unf = zapStableUnfolding arg+                          -- See Note [Zap unfolding when beta-reducing]+                          -- in GHC.Core.Opt.Simplify; and see #13890+             rebox_fn   = Let (NonRec arg_no_unf con_app)+             con_app    = mkConApp2 dc tc_args (ex_tvs' ++ arg_ids') `mkCast` mkSymCo co+       ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False (ex_tvs' ++ arg_ids')+       ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) }+                          -- Don't pass the arg, rebox instead  ---------------------- nop_fn :: CoreExpr -> CoreExpr@@ -932,74 +935,68 @@ Historical note: #14955 describes how I got this fix wrong the first time. -} --- | Context for a 'DataCon' application with a hole for every field, including--- surrounding coercions.--- The result of 'deepSplitProductType_maybe' and 'deepSplitCprType_maybe'.------ Example:------ > DataConAppContext Just [Int] [(Lazy, Int)] (co :: Maybe Int ~ First Int)------ represents------ > Just @Int (_1 :: Int) |> co :: First Int+-- | The result of 'splitArgType_maybe' and 'splitResultType_maybe'. ----- where _1 is a hole for the first argument. The number of arguments is--- determined by the length of @arg_tys@.-data DataConAppContext-  = DataConAppContext-  { dcac_dc      :: !DataCon-  , dcac_tys     :: ![Type]-  , dcac_arg_tys :: ![(Scaled Type, StrictnessMark)]-  , dcac_co      :: !Coercion+-- Both splits+--   * Take a type `ty`+--   * Succeed with (DataConPatContext dc tys co)+--     iff co :: T tys ~ ty+--     and `dc` is the appropriate DataCon of `T`+--     and `T` is suitable for the kind of split+--     (differs for strictness and CPR, see Note [Which types are unboxed?])+data DataConPatContext+  = DataConPatContext+  { dcpc_dc        :: !DataCon+  , dcpc_tc_args   :: ![Type]+  , dcpc_co        :: !Coercion   } -deepSplitProductType_maybe :: FamInstEnvs -> Type -> Maybe DataConAppContext--- If    deepSplitProductType_maybe ty = Just (dc, tys, arg_tys, co)--- then  dc @ tys (args::arg_tys) :: rep_ty---       co :: ty ~ rep_ty--- Why do we return the strictness of the data-con arguments?--- Answer: see Note [Record evaluated-ness in worker/wrapper]-deepSplitProductType_maybe fam_envs ty+-- | If @splitArgType_maybe ty = Just (dc, tys, co)@+-- then @dc \@tys \@_ex_tys (_args::_arg_tys) :: tc tys@+-- and  @co :: ty ~ tc tys@+-- where underscore prefixes are holes, e.g. yet unspecified.+--+-- See Note [Which types are unboxed?].+splitArgType_maybe :: FamInstEnvs -> Type -> Maybe DataConPatContext+splitArgType_maybe fam_envs ty   | let (co, ty1) = topNormaliseType_maybe fam_envs ty                     `orElse` (mkRepReflCo ty, ty)   , Just (tc, tc_args) <- splitTyConApp_maybe ty1-  , Just con <- isDataProductTyCon_maybe tc-  , let arg_tys = dataConInstArgTys con tc_args-        strict_marks = dataConRepStrictness con-  = Just DataConAppContext { dcac_dc = con-                           , dcac_tys = tc_args-                           , dcac_arg_tys = zipEqual "dspt" arg_tys strict_marks-                           , dcac_co = co }-deepSplitProductType_maybe _ _ = Nothing+  , Just con <- tyConSingleAlgDataCon_maybe tc+  = Just DataConPatContext { dcpc_dc      = con+                           , dcpc_tc_args = tc_args+                           , dcpc_co      = co }+splitArgType_maybe _ _ = Nothing -deepSplitCprType_maybe-  :: FamInstEnvs -> ConTag -> Type -> Maybe DataConAppContext--- If    deepSplitCprType_maybe n ty = Just (dc, tys, arg_tys, co)--- then  dc @ tys (args::arg_tys) :: rep_ty---       co :: ty ~ rep_ty--- Why do we return the strictness of the data-con arguments?--- Answer: see Note [Record evaluated-ness in worker/wrapper]-deepSplitCprType_maybe fam_envs con_tag ty+-- | If @splitResultType_maybe n ty = Just (dc, tys, co)@+-- then @dc \@tys \@_ex_tys (_args::_arg_tys) :: tc tys@+-- and  @co :: ty ~ tc tys@+-- where underscore prefixes are holes, e.g. yet unspecified.+-- @dc@ is the @n@th data constructor of @tc@.+--+-- See Note [Which types are unboxed?].+splitResultType_maybe :: FamInstEnvs -> ConTag -> Type -> Maybe DataConPatContext+splitResultType_maybe fam_envs con_tag ty   | let (co, ty1) = topNormaliseType_maybe fam_envs ty                     `orElse` (mkRepReflCo ty, ty)   , Just (tc, tc_args) <- splitTyConApp_maybe ty1-  , isDataTyCon tc+  , isDataTyCon tc -- NB: rules out unboxed sums and pairs!   , let cons = tyConDataCons tc   , cons `lengthAtLeast` con_tag -- This might not be true if we import the-                                 -- type constructor via a .hs-bool file (#8743)+                                 -- type constructor via a .hs-boot file (#8743)   , let con = cons `getNth` (con_tag - fIRST_TAG)-        arg_tys = dataConInstArgTys con tc_args-        strict_marks = dataConRepStrictness con-  , all isLinear arg_tys+  , null (dataConExTyCoVars con) -- no existentials;+                                 -- See Note [Which types are unboxed?]+                                 -- and GHC.Core.Opt.CprAnal.extendEnvForDataAlt+                                 -- where we also check this.+  , all isLinear (dataConInstArgTys con tc_args)   -- Deactivates CPR worker/wrapper splits on constructors with non-linear   -- arguments, for the moment, because they require unboxed tuple with variable   -- multiplicity fields.-  = Just DataConAppContext { dcac_dc = con-                           , dcac_tys = tc_args-                           , dcac_arg_tys = zipEqual "dspt" arg_tys strict_marks-                           , dcac_co = co }-deepSplitCprType_maybe _ _ _ = Nothing+  = Just DataConPatContext { dcpc_dc = con+                           , dcpc_tc_args = tc_args+                           , dcpc_co = co }+splitResultType_maybe _ _ _ = Nothing  isLinear :: Scaled a -> Bool isLinear (Scaled w _ ) =@@ -1035,13 +1032,16 @@        | Just (_, rhs, _) <- topReduceTyFamApp_maybe fam_envs tc tc_args        = go rec_tc rhs -       | Just con <- isDataProductTyCon_maybe tc+       | Just con <- tyConSingleAlgDataCon_maybe tc        , Just rec_tc <- if isTupleTyCon tc                         then Just rec_tc                         else checkRecTc rec_tc tc          -- We treat tuples specially because they can't cause loops.          -- Maybe we should do so in checkRecTc.-       = TsProd (map (go rec_tc . scaledThing) (dataConInstArgTys con tc_args))+         -- The use of 'dubiousDataConInstArgTys' is OK, since this+         -- function performs no substitution at all, hence the uniques+         -- don't matter.+       = TsProd (map (go rec_tc) (dubiousDataConInstArgTys con tc_args))         | Just (ty', _) <- instNewTyCon_maybe tc tc_args        , Just rec_tc <- checkRecTc rec_tc tc@@ -1050,7 +1050,55 @@        | otherwise        = TsUnk -{-+-- | Exactly 'dataConInstArgTys', but lacks the (ASSERT'ed) precondition that+-- the 'DataCon' may not have existentials. The lack of cloning the existentials+-- compared to 'dataConInstExAndArgVars' makes this function \"dubious\";+-- only use it where type variables aren't substituted for!+dubiousDataConInstArgTys :: DataCon -> [Type] -> [Type]+dubiousDataConInstArgTys dc tc_args = arg_tys+  where+    univ_tvs = dataConUnivTyVars dc+    ex_tvs   = dataConExTyCoVars dc+    subst    = extendTCvInScopeList (zipTvSubst univ_tvs tc_args) ex_tvs+    arg_tys  = map (substTy subst . scaledThing) (dataConRepArgTys dc)++{- Note [Which types are unboxed?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Worker/wrapper will unbox++  1. A strict data type argument, that+       * is an algebraic data type (not a newtype)+       * has a single constructor (thus is a "product")+       * that may bind existentials+     We can transform+     > f (D @ex a b) = e+     to+     > $wf @ex a b = e+     via 'mkWWstr'.++  2. The constructed result of a function, if+       * its type is an algebraic data type (not a newtype)+       * (might have multiple constructors, in contrast to (1))+       * the applied data constructor *does not* bind existentials+     We can transform+     > f x y = let ... in D a b+     to+     > $wf x y = let ... in (# a, b #)+     via 'mkWWcpr'.++     NB: We don't allow existentials for CPR W/W, because we don't have unboxed+     dependent tuples (yet?). Otherwise, we could transform+     > f x y = let ... in D @ex (a :: ..ex..) (b :: ..ex..)+     to+     > $wf x y = let ... in (# @ex, (a :: ..ex..), (b :: ..ex..) #)++The respective tests are in 'splitArgType_maybe' and+'splitResultType_maybe', respectively.++Note that the data constructor /can/ have evidence arguments: equality+constraints, type classes etc.  So it can be GADT.  These evidence+arguments are simply value arguments, and should not get in the way.+ ************************************************************************ *                                                                      * \subsection{CPR stuff}@@ -1083,35 +1131,36 @@   | otherwise   = case asConCpr cpr of        Nothing      -> return (False, id, id, body_ty)  -- No CPR info-       Just con_tag | Just dcac <- deepSplitCprType_maybe fam_envs con_tag body_ty-                    -> mkWWcpr_help dcac+       Just con_tag | Just dcpc <- splitResultType_maybe fam_envs con_tag body_ty+                    -> mkWWcpr_help dcpc                     |  otherwise                        -- See Note [non-algebraic or open body type warning]                     -> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty )                        return (False, id, id, body_ty) -mkWWcpr_help :: DataConAppContext+mkWWcpr_help :: DataConPatContext              -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type) -mkWWcpr_help (DataConAppContext { dcac_dc = data_con, dcac_tys = inst_tys-                                , dcac_arg_tys = arg_tys, dcac_co = co })-  | [arg1@(arg_ty1, _)] <- arg_tys-  , isUnliftedType (scaledThing arg_ty1)-  , isLinear arg_ty1+mkWWcpr_help (DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args+                                , dcpc_co = co })+  | [arg_ty]   <- dataConInstArgTys dc tc_args -- NB: No existentials!+  , [str_mark] <- dataConRepStrictness dc+  , isUnliftedType (scaledThing arg_ty)+  , isLinear arg_ty         -- Special case when there is a single result of unlifted, linear, type         --         -- Wrapper:     case (..call worker..) of x -> C x         -- Worker:      case (   ..body..    ) of C x -> x   = do { (work_uniq : arg_uniq : _) <- getUniquesM-       ; let arg       = mk_ww_local arg_uniq arg1-             con_app   = mkConApp2 data_con inst_tys [arg] `mkCast` mkSymCo co+       ; let arg_id    = mk_ww_local arg_uniq str_mark arg_ty+             con_app   = mkConApp2 dc tc_args [arg_id] `mkCast` mkSymCo co         ; return ( True-                , \ wkr_call -> mkDefaultCase wkr_call arg con_app-                , \ body     -> mkUnpackCase body co One work_uniq data_con [arg] (varToCoreExpr arg)+                , \ wkr_call -> mkDefaultCase wkr_call arg_id con_app+                , \ body     -> mkUnpackCase body co One work_uniq dc [arg_id] (varToCoreExpr arg_id)                                 -- varToCoreExpr important here: arg can be a coercion                                 -- Lacking this caused #10658-                , scaledThing arg_ty1 ) }+                , scaledThing arg_ty ) }    | otherwise   -- The general case         -- Wrapper: case (..call worker..) of (# a, b #) -> C a b@@ -1123,18 +1172,22 @@         -- parametrised by the multiplicity of its fields. Specifically, in this         -- instance, the multiplicity of the fields of (#,#) is chosen to be the         -- same as those of C.-  = do { (work_uniq : wild_uniq : uniqs) <- getUniquesM-       ; let wrap_wild   = mk_ww_local wild_uniq (linear ubx_tup_ty,MarkedStrict)-             args        = zipWith mk_ww_local uniqs arg_tys-             ubx_tup_ty  = exprType ubx_tup_app-             ubx_tup_app = mkCoreUbxTup (map (scaledThing . fst) arg_tys) (map varToCoreExpr args)-             con_app     = mkConApp2 data_con inst_tys args `mkCast` mkSymCo co-             tup_con     = tupleDataCon Unboxed (length arg_tys)+  = do { (work_uniq : wild_uniq : pat_bndrs_uniqs) <- getUniquesM+       ; let case_mult       = One -- see above+             (_exs, arg_ids) =+               dataConRepFSInstPat (repeat ww_prefix) pat_bndrs_uniqs case_mult dc tc_args+             wrap_wild       = mk_ww_local wild_uniq MarkedStrict (Scaled case_mult ubx_tup_ty)+             ubx_tup_ty      = exprType ubx_tup_app+             ubx_tup_app     = mkCoreUbxTup (map idType arg_ids) (map varToCoreExpr arg_ids)+             con_app         = mkConApp2 dc tc_args arg_ids `mkCast` mkSymCo co+             tup_con         = tupleDataCon Unboxed (length arg_ids) +       ; MASSERT( null _exs ) -- Should have been caught by splitResultType_maybe+        ; return (True                 , \ wkr_call -> mkSingleAltCase wkr_call wrap_wild-                                                (DataAlt tup_con) args con_app-                , \ body     -> mkUnpackCase body co One work_uniq data_con args ubx_tup_app+                                                (DataAlt tup_con) arg_ids con_app+                , \ body     -> mkUnpackCase body co case_mult work_uniq dc arg_ids ubx_tup_app                 , ubx_tup_ty ) }  mkUnpackCase ::  CoreExpr -> Coercion -> Mult -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr@@ -1149,7 +1202,7 @@                     (DataAlt boxing_con) unpk_args body   where     casted_scrut = scrut `mkCast` co-    bndr = mk_ww_local uniq (Scaled mult (exprType casted_scrut), MarkedStrict)+    bndr = mk_ww_local uniq MarkedStrict (Scaled mult (exprType casted_scrut))       -- An unpacking case can always be chosen linear, because the variables       -- are always passed to a constructor. This limits the {-@@ -1275,10 +1328,14 @@      abs_rhs      = mkAbsentErrorApp arg_ty msg     msg          = showSDoc (gopt_set dflags Opt_SuppressUniques)-                            (ppr arg <+> ppr (idType arg) <+> file_msg)+                            (vcat+                              [ text "Arg:" <+> ppr arg+                              , text "Type:" <+> ppr arg_ty+                              , file_msg+                              ])     file_msg     = case outputFile dflags of                      Nothing -> empty-                     Just f  -> text "in output file " <+> quotes (text f)+                     Just f  -> text "In output file " <+> quotes (text f)               -- We need to suppress uniques here because otherwise they'd               -- end up in the generated code as strings. This is bad for               -- determinism, because with different uniques the strings@@ -1287,10 +1344,13 @@               -- See also Note [Unique Determinism] in GHC.Types.Unique     unlifted_rhs = mkTyApps (Lit rubbishLit) [arg_ty] -mk_ww_local :: Unique -> (Scaled Type, StrictnessMark) -> Id+ww_prefix :: FastString+ww_prefix = fsLit "ww"++mk_ww_local :: Unique -> StrictnessMark -> Scaled Type -> Id -- The StrictnessMark comes form the data constructor and says -- whether this field is strict -- See Note [Record evaluated-ness in worker/wrapper]-mk_ww_local uniq (Scaled w ty,str)+mk_ww_local uniq str (Scaled w ty)   = setCaseBndrEvald str $-    mkSysLocalOrCoVar (fsLit "ww") uniq w ty+    mkSysLocalOrCoVar ww_prefix uniq w ty

@@ -21,7 +21,7 @@ import GHC.Core.Seq ( seqUnfolding ) import GHC.Types.Id import GHC.Types.Id.Info-import GHC.Types.Demand ( zapUsageEnvSig )+import GHC.Types.Demand ( zapDmdEnvSig ) import GHC.Core.Type     ( tidyType, tidyVarBndr ) import GHC.Core.Coercion ( tidyCo ) import GHC.Types.Var@@ -206,7 +206,7 @@         new_info = vanillaIdInfo                     `setOccInfo`        occInfo old_info                     `setArityInfo`      arityInfo old_info-                    `setStrictnessInfo` zapUsageEnvSig (strictnessInfo old_info)+                    `setStrictnessInfo` zapDmdEnvSig (strictnessInfo old_info)                     `setDemandInfo`     demandInfo old_info                     `setInlinePragInfo` inlinePragInfo old_info                     `setUnfoldingInfo`  new_unf

@@ -768,7 +768,10 @@             -> UniqSM (Floats, CpeRhs)     cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args) depth         | f `hasKey` lazyIdKey          -- Replace (lazy a) with a, and+            -- See Note [lazyId magic] in GHC.Types.Id.Make        || f `hasKey` noinlineIdKey      -- Replace (noinline a) with a+            -- See Note [noinlineId magic] in GHC.Types.Id.Make+         -- Consider the code:         --         --      lazy (f x) y

@@ -56,10 +56,12 @@ import GHC.Utils.Error  import GHC.Unit+import GHC.Unit.Env import GHC.Unit.External import GHC.Unit.State import GHC.Unit.Finder-import GHC.Unit.Module.ModSummary (showModMsg)+import GHC.Unit.Module.Graph+import GHC.Unit.Module.ModSummary import GHC.Unit.Home.ModInfo  import GHC.Linker.Types@@ -69,6 +71,7 @@ import GHC.Data.Maybe import GHC.Data.StringBuffer import GHC.Data.FastString+import qualified GHC.Data.EnumSet as EnumSet import qualified GHC.Data.ShortText as ST  import Data.List ( partition )@@ -81,6 +84,7 @@ import Data.IORef import Data.Map (Map) import qualified Data.Map as Map+import qualified Data.Set as Set  -- | Entry point to compile a Backpack file. doBackpack :: [FilePath] -> Ghc ()@@ -103,8 +107,8 @@         POk _ pkgname_bkp -> do             -- OK, so we have an LHsUnit PackageName, but we want an             -- LHsUnit HsComponentId.  So let's rename it.-            let pkgstate = unitState dflags-            let bkp = renameHsUnits pkgstate (bkpPackageNameMap pkgname_bkp) pkgname_bkp+            hsc_env <- getSession+            let bkp = renameHsUnits (hsc_units hsc_env) (bkpPackageNameMap pkgname_bkp) pkgname_bkp             initBkpM src_filename bkp $                 forM_ (zip [1..] bkp) $ \(i, lunit) -> do                     let comp_name = unLoc (hsunitName (unLoc lunit))@@ -170,62 +174,68 @@                  -- Special case when package is definite                  , not (null insts) = sub_comp (key_base p) </> uid_str                  | otherwise = sub_comp (key_base p)-    withTempSession (overHscDynFlags (\dflags ->-      -- If we're type-checking an indefinite package, we want to-      -- turn on interface writing.  However, if the user also-      -- explicitly passed in `-fno-code`, we DON'T want to write-      -- interfaces unless the user also asked for `-fwrite-interface`.-      -- See Note [-fno-code mode]-      (case session_type of-        -- Make sure to write interfaces when we are type-checking-        -- indefinite packages.-        TcSession | backend dflags /= NoBackend-                  -> flip gopt_set Opt_WriteInterface-                  | otherwise -> id-        CompSession -> id-        ExeSession -> id) $-      dflags {-        backend   = case session_type of-                        TcSession -> NoBackend-                        _ -> backend dflags,-        homeUnitInstantiations_ = insts,-                                 -- if we don't have any instantiation, don't-                                 -- fill `homeUnitInstanceOfId` as it makes no-                                 -- sense (we're not instantiating anything)-        homeUnitInstanceOf_   = if null insts then Nothing else Just (indefUnit cid),-        homeUnitId_ =-            case session_type of++        mk_temp_env hsc_env = hsc_env+            { hsc_dflags   = mk_temp_dflags (hsc_units hsc_env) (hsc_dflags hsc_env)+            }+        mk_temp_dflags unit_state dflags = dflags+            { backend = case session_type of+                            TcSession -> NoBackend+                            _         -> backend dflags+            , homeUnitInstantiations_ = insts+                                     -- if we don't have any instantiation, don't+                                     -- fill `homeUnitInstanceOfId` as it makes no+                                     -- sense (we're not instantiating anything)+            , homeUnitInstanceOf_   = if null insts then Nothing else Just (indefUnit cid)+            , homeUnitId_ = case session_type of                 TcSession -> newUnitId cid Nothing                 -- No hash passed if no instances                 _ | null insts -> newUnitId cid Nothing-                  | otherwise  -> newUnitId cid (Just (mkInstantiatedUnitHash cid insts)),-        -- Setup all of the output directories according to our hierarchy-        objectDir   = Just (outdir objectDir),-        hiDir       = Just (outdir hiDir),-        stubDir     = Just (outdir stubDir),-        -- Unset output-file for non exe builds-        outputFile_  = if session_type == ExeSession-                        then outputFile_ dflags-                        else Nothing,-        dynOutputFile_ = if session_type == ExeSession-                        then dynOutputFile_ dflags-                        else Nothing,-        -- Clear the import path so we don't accidentally grab anything-        importPaths = [],-        -- Synthesized the flags-        packageFlags = packageFlags dflags ++ map (\(uid0, rn) ->-          let state = unitState dflags-              uid = unwireUnit state (improveUnit state $ renameHoleUnit state (listToUFM insts) uid0)-          in ExposePackage-            (showSDoc dflags-                (text "-unit-id" <+> ppr uid <+> ppr rn))-            (UnitIdArg uid) rn) deps-      } )) $ do-        dflags <- getSessionDynFlags-        -- pprTrace "flags" (ppr insts <> ppr deps) $ return ()-        setSessionDynFlags dflags -- calls initUnits-        do_this+                  | otherwise  -> newUnitId cid (Just (mkInstantiatedUnitHash cid insts)) ++            -- If we're type-checking an indefinite package, we want to+            -- turn on interface writing.  However, if the user also+            -- explicitly passed in `-fno-code`, we DON'T want to write+            -- interfaces unless the user also asked for `-fwrite-interface`.+            -- See Note [-fno-code mode]+            , generalFlags = case session_type of+                -- Make sure to write interfaces when we are type-checking+                -- indefinite packages.+                TcSession+                  | backend dflags /= NoBackend+                  -> EnumSet.insert Opt_WriteInterface (generalFlags dflags)+                _ -> generalFlags dflags++            -- Setup all of the output directories according to our hierarchy+            , objectDir   = Just (outdir objectDir)+            , hiDir       = Just (outdir hiDir)+            , stubDir     = Just (outdir stubDir)+            -- Unset output-file for non exe builds+            , outputFile_ = case session_type of+                ExeSession -> outputFile_ dflags+                _          -> Nothing+            , dynOutputFile_ = case session_type of+                ExeSession -> dynOutputFile_ dflags+                _          -> Nothing+            -- Clear the import path so we don't accidentally grab anything+            , importPaths = []+            -- Synthesize the flags+            , packageFlags = packageFlags dflags ++ map (\(uid0, rn) ->+              let uid = unwireUnit unit_state+                        $ improveUnit unit_state+                        $ renameHoleUnit unit_state (listToUFM insts) uid0+              in ExposePackage+                (showSDoc dflags+                    (text "-unit-id" <+> ppr uid <+> ppr rn))+                (UnitIdArg uid) rn) deps+            }+    withTempSession mk_temp_env $ do+      dflags <- getSessionDynFlags+      -- pprTrace "flags" (ppr insts <> ppr deps) $ return ()+      setSessionDynFlags dflags -- calls initUnits+      do_this+ withBkpExeSession :: [(Unit, ModRenaming)] -> BkpM a -> BkpM a withBkpExeSession deps do_this =     withBkpSession (Indefinite (UnitId (fsLit "main"))) [] deps ExeSession do_this@@ -278,11 +288,11 @@     -- any object files.     let deps_w_rns = hsunitDeps (session == TcSession) (unLoc lunit)         raw_deps = map fst deps_w_rns-    dflags <- getDynFlags+    hsc_env <- getSession     -- The compilation dependencies are just the appropriately filled     -- in unit IDs which must be compiled before we can compile.     let hsubst = listToUFM insts-        deps0 = map (renameHoleUnit (unitState dflags) hsubst) raw_deps+        deps0 = map (renameHoleUnit (hsc_units hsc_env) hsubst) raw_deps      -- Build dependencies OR make sure they make sense. BUT NOTE,     -- we can only check the ones that are fully filled; the rest@@ -293,9 +303,8 @@             TcSession -> return ()             _ -> compileInclude (length deps0) (i, dep) -    dflags <- getDynFlags     -- IMPROVE IT-    let deps = map (improveUnit (unitState dflags)) deps0+    let deps = map (improveUnit (hsc_units hsc_env)) deps0      mb_old_eps <- case session of                     TcSession -> fmap Just getEpsGhc@@ -324,7 +333,7 @@                       $ home_mod_infos             getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)             obj_files = concatMap getOfiles linkables-            state     = unitState (hsc_dflags hsc_env)+            state     = hsc_units hsc_env          let compat_fs = unitIdFS (indefUnit cid)             compat_pn = PackageName compat_fs@@ -380,7 +389,7 @@             }  -    addPackage conf+    addUnit conf     case mb_old_eps of         Just old_eps -> updateEpsGhc_ (const old_eps)         _ -> return ()@@ -400,22 +409,33 @@         when (failed ok) (liftIO $ exitWith (ExitFailure 1))  -- | Register a new virtual unit database containing a single unit-addPackage :: GhcMonad m => UnitInfo -> m ()-addPackage pkg = do-    dflags <- GHC.getSessionDynFlags-    case unitDatabases dflags of-        Nothing -> panic "addPackage: called too early"-        Just dbs -> do+addUnit :: GhcMonad m => UnitInfo -> m ()+addUnit u = do+    hsc_env <- getSession+    newdbs <- case hsc_unit_dbs hsc_env of+        Nothing  -> panic "addUnit: called too early"+        Just dbs ->          let newdb = UnitDatabase-               { unitDatabasePath  = "(in memory " ++ showSDoc dflags (ppr (unitId pkg)) ++ ")"-               , unitDatabaseUnits = [pkg]+               { unitDatabasePath  = "(in memory " ++ showSDoc (hsc_dflags hsc_env) (ppr (unitId u)) ++ ")"+               , unitDatabaseUnits = [u]                }-         GHC.setSessionDynFlags (dflags { unitDatabases = Just (dbs ++ [newdb]) })+         in return (dbs ++ [newdb]) -- added at the end because ordering matters+    (dbs,unit_state,home_unit) <- liftIO $ initUnits (hsc_dflags hsc_env) (Just newdbs)+    let unit_env = UnitEnv+          { ue_platform  = targetPlatform (hsc_dflags hsc_env)+          , ue_namever   = ghcNameVersion (hsc_dflags hsc_env)+          , ue_home_unit = home_unit+          , ue_units     = unit_state+          }+    setSession $ hsc_env+        { hsc_unit_dbs = Just dbs+        , hsc_unit_env = unit_env+        }  compileInclude :: Int -> (Int, Unit) -> BkpM () compileInclude n (i, uid) = do     hsc_env <- getSession-    let pkgs = unitState (hsc_dflags hsc_env)+    let pkgs = hsc_units hsc_env     msgInclude (i, n) uid     -- Check if we've compiled it already     case uid of@@ -469,10 +489,6 @@ getBkpLevel :: BkpM Int getBkpLevel = bkp_level `fmap` getBkpEnv --- | Apply a function on 'DynFlags' on an 'HscEnv'-overHscDynFlags :: (DynFlags -> DynFlags) -> HscEnv -> HscEnv-overHscDynFlags f hsc_env = hsc_env { hsc_dflags = f (hsc_dflags hsc_env) }- -- | Run a 'BkpM' computation, with the nesting level bumped one. innerBkpM :: BkpM a -> BkpM a innerBkpM do_this =@@ -520,19 +536,28 @@ mkBackpackMsg :: BkpM Messager mkBackpackMsg = do     level <- getBkpLevel-    return $ \hsc_env mod_index recomp mod_summary ->+    return $ \hsc_env mod_index recomp node ->       let dflags = hsc_dflags hsc_env-          state = unitState dflags+          state = hsc_units hsc_env           showMsg msg reason =             backpackProgressMsg level dflags $ pprWithUnitState state $                 showModuleIndex mod_index <>-                msg <> showModMsg dflags (recompileRequired recomp) mod_summary+                msg <> showModMsg dflags (recompileRequired recomp) node                     <> reason-      in case recomp of+      in case node of+        InstantiationNode _ ->+          case recomp of+            MustCompile -> showMsg (text "Instantiating ") empty+            UpToDate+              | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping  ") empty+              | otherwise -> return ()+            RecompBecause reason -> showMsg (text "Instantiating ") (text " [" <> text reason <> text "]")+        ModuleNode _ ->+          case recomp of             MustCompile -> showMsg (text "Compiling ") empty             UpToDate-                | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping  ") empty-                | otherwise -> return ()+              | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping  ") empty+              | otherwise -> return ()             RecompBecause reason -> showMsg (text "Compiling ") (text " [" <> text reason <> text "]")  -- | 'PprStyle' for Backpack messages; here we usually want the module to@@ -557,8 +582,9 @@ msgUnitId :: Unit -> BkpM () msgUnitId pk = do     dflags <- getDynFlags+    hsc_env <- getSession     level <- getBkpLevel-    let state = unitState dflags+    let state = hsc_units hsc_env     liftIO . backpackProgressMsg level dflags         $ pprWithUnitState state         $ text "Instantiating "@@ -568,8 +594,9 @@ msgInclude :: (Int,Int) -> Unit -> BkpM () msgInclude (i,n) uid = do     dflags <- getDynFlags+    hsc_env <- getSession     level <- getBkpLevel-    let state = unitState dflags+    let state = hsc_units hsc_env     liftIO . backpackProgressMsg level dflags         $ pprWithUnitState state         $ showModuleIndex (i, n) <> text "Including "@@ -663,6 +690,7 @@ hsunitModuleGraph :: HsUnit HsComponentId -> BkpM ModuleGraph hsunitModuleGraph unit = do     hsc_env <- getSession+     let decls = hsunitBody unit         pn = hsPackageName (unLoc (hsunitName unit))         home_unit = hsc_home_unit hsc_env@@ -677,16 +705,21 @@     --  2. For each hole which does not already have an hsig file,     --  create an "empty" hsig file to induce compilation for the     --  requirement.-    let node_map = Map.fromList [ ((ms_mod_name n, ms_hsc_src n == HsigFile), n)-                                | n <- nodes ]+    let hsig_set = Set.fromList+          [ ms_mod_name ms+          | ExtendedModSummary { emsModSummary = ms } <- nodes+          , ms_hsc_src ms == HsigFile+          ]     req_nodes <- fmap catMaybes . forM (homeUnitInstantiations home_unit) $ \(mod_name, _) ->-        let has_local = Map.member (mod_name, True) node_map-        in if has_local+        if Set.member mod_name hsig_set             then return Nothing-            else fmap Just $ summariseRequirement pn mod_name+            else fmap (Just . extendModSummaryNoDeps) $ summariseRequirement pn mod_name+            -- Using extendModSummaryNoDeps here is okay because we're making a leaf node+            -- representing a signature that can't depend on any other unit.      -- 3. Return the kaboodle-    return $ mkModuleGraph $ nodes ++ req_nodes+    return $ mkModuleGraph' $+      (ModuleNode <$> (nodes ++ req_nodes)) ++ instantiationNodes (hsc_units hsc_env)  summariseRequirement :: PackageName -> ModuleName -> BkpM ModSummary summariseRequirement pn mod_name = do@@ -739,14 +772,14 @@               -> HscSource               -> Located ModuleName               -> Maybe (Located HsModule)-              -> BkpM ModSummary+              -> BkpM ExtendedModSummary summariseDecl pn hsc_src (L _ modname) (Just hsmod) = hsModuleToModSummary pn hsc_src modname hsmod summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing     = do hsc_env <- getSession          let dflags = hsc_dflags hsc_env          -- TODO: this looks for modules in the wrong place          r <- liftIO $ summariseModule hsc_env-                         Map.empty -- GHC API recomp not supported+                         emptyModNodeMap -- GHC API recomp not supported                          (hscSourceToIsBoot hsc_src)                          lmodname                          True -- Target lets you disallow, but not here@@ -766,7 +799,7 @@                      -> HscSource                      -> ModuleName                      -> Located HsModule-                     -> BkpM ModSummary+                     -> BkpM ExtendedModSummary hsModuleToModSummary pn hsc_src modname                      hsmod = do     let imps = hsmodImports (unLoc hsmod)@@ -814,11 +847,13 @@     extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname      let normal_imports = map convImport (implicit_imports ++ ordinary_imps)-    required_by_imports <- liftIO $ implicitRequirements hsc_env normal_imports+    (implicit_sigs, inst_deps) <- liftIO $ implicitRequirementsShallow hsc_env normal_imports      -- So that Finder can find it, even though it doesn't exist...     this_mod <- liftIO $ addHomeModuleToFinder hsc_env modname location-    return ModSummary {+    return $ ExtendedModSummary+      { emsModSummary =+          ModSummary {             ms_mod = this_mod,             ms_hsc_src = hsc_src,             ms_location = location,@@ -833,7 +868,7 @@                            -- due to merging, requirements may end up with                            -- extra imports                            ++ extra_sig_imports-                           ++ required_by_imports,+                           ++ ((,) Nothing . noLoc <$> implicit_sigs),             -- This is our hack to get the parse tree to the right spot             ms_parsed_mod = Just (HsParsedModule {                     hpm_module = hsmod,@@ -844,7 +879,9 @@             ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS             ms_iface_date = hi_timestamp,             ms_hie_date = hie_timestamp-        }+          }+      , emsInstantiatedUnits = inst_deps+      }  -- | Create a new, externally provided hashed unit id from -- a hash.

@@ -64,6 +64,7 @@ -}  codeOutput :: DynFlags+           -> UnitState            -> Module            -> FilePath            -> ModLocation@@ -77,7 +78,7 @@                   [(ForeignSrcLang, FilePath)]{-foreign_fps-},                   a) -codeOutput dflags this_mod filenm location foreign_stubs foreign_fps pkg_deps+codeOutput dflags unit_state this_mod filenm location foreign_stubs foreign_fps pkg_deps   cmm_stream   =     do  {@@ -104,7 +105,7 @@                 ; return cmm                 } -        ; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs+        ; stubs_exist <- outputForeignStubs dflags unit_state this_mod location foreign_stubs         ; a <- case backend dflags of                  NCG         -> outputAsm dflags this_mod location filenm                                           linted_cmm_stream@@ -190,10 +191,10 @@ ************************************************************************ -} -outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs+outputForeignStubs :: DynFlags -> UnitState -> Module -> ModLocation -> ForeignStubs                    -> IO (Bool,         -- Header file created                           Maybe FilePath) -- C file created-outputForeignStubs dflags mod location stubs+outputForeignStubs dflags unit_state mod location stubs  = do    let stub_h = mkStubPaths dflags (moduleName mod) location    stub_c <- newTempName dflags TFL_CurrentModule "c"@@ -220,7 +221,7 @@          -- we need the #includes from the rts package for the stub files         let rts_includes =-               let rts_pkg = unsafeLookupUnitId (unitState dflags) rtsUnitId in+               let rts_pkg = unsafeLookupUnitId unit_state rtsUnitId in                concatMap mk_include (unitIncludes rts_pkg)             mk_include i = "#include \"" ++ ST.unpack i ++ "\"\n" 

@@ -235,12 +235,16 @@  newHscEnv :: DynFlags -> IO HscEnv newHscEnv dflags = do-    let home_unit = mkHomeUnitFromFlags dflags-    eps_var <- newIORef (initExternalPackageState home_unit)+    -- we don't store the unit databases and the unit state to still+    -- allow `setSessionDynFlags` to be used to set unit db flags.+    eps_var <- newIORef (initExternalPackageState (homeUnitId_ dflags))     us      <- mkSplitUniqSupply 'r'     nc_var  <- newIORef (initNameCache us knownKeyNames)     fc_var  <- newIORef emptyInstalledModuleEnv     emptyLoader <- uninitializedLoader+    -- FIXME: it's sad that we have so many "unitialized" fields filled with+    -- empty stuff or lazy panics. We should have two kinds of HscEnv+    -- (initialized or not) instead and less fields that are mutable over time.     return HscEnv {  hsc_dflags         = dflags                   ,  hsc_targets        = []                   ,  hsc_mod_graph      = emptyMG@@ -252,9 +256,10 @@                   ,  hsc_type_env_var   = Nothing                   ,  hsc_interp         = Nothing                   ,  hsc_loader         = emptyLoader-                  ,  hsc_home_unit      = home_unit+                  ,  hsc_unit_env       = panic "hsc_unit_env not initialized"                   ,  hsc_plugins        = []                   ,  hsc_static_plugins = []+                  ,  hsc_unit_dbs       = Nothing                   }  -- -----------------------------------------------------------------------------@@ -280,7 +285,7 @@  -- | log warning in the monad, and if there are errors then -- throw a SourceError exception.-logWarningsReportErrors :: (Bag Warning, Bag Error) -> Hsc ()+logWarningsReportErrors :: (Bag PsWarning, Bag PsError) -> Hsc () logWarningsReportErrors (warnings,errors) = do     let warns = fmap pprWarning warnings         errs  = fmap pprError   errors@@ -289,7 +294,7 @@  -- | Log warnings and throw errors, assuming the messages -- contain at least one error (e.g. coming from PFailed)-handleWarningsThrowErrors :: (Bag Warning, Bag Error) -> Hsc a+handleWarningsThrowErrors :: (Bag PsWarning, Bag PsError) -> Hsc a handleWarningsThrowErrors (warnings, errors) = do     let warns = fmap pprWarning warnings         errs  = fmap pprError   errors@@ -670,7 +675,7 @@ -}  -type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModSummary -> IO ()+type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModuleGraphNode -> IO ()  -- | This function runs GHC's frontend with recompilation -- avoidance. Specifically, it checks if recompilation is needed,@@ -693,8 +698,9 @@     hsc_env <- getHscEnv      let msg what = case mHscMessage of-                   Just hscMessage -> hscMessage hsc_env mod_index what mod_summary-                   Nothing -> return ()+          -- We use extendModSummaryNoDeps because extra backpack deps are only needed for batch mode+          Just hscMessage -> hscMessage hsc_env mod_index what (ModuleNode (extendModSummaryNoDeps mod_summary))+          Nothing -> return ()          skip iface = do             liftIO $ msg UpToDate@@ -702,8 +708,11 @@          compile mb_old_hash reason = do             liftIO $ msg reason-            (tc_result, _) <- hsc_typecheck False mod_summary Nothing-            return $ Right (FrontendTypecheck tc_result, mb_old_hash)+            tc_result <- do+                let def ms = FrontendTypecheck . fst <$> hsc_typecheck False ms Nothing+                action <- getHooked hscFrontendHook def+                action mod_summary+            return $ Right (tc_result, mb_old_hash)          stable = case source_modified of                      SourceUnmodifiedAndStable -> True@@ -1023,19 +1032,27 @@             return ()  batchMsg :: Messager-batchMsg hsc_env mod_index recomp mod_summary =-    case recomp of-        MustCompile -> showMsg (text "Compiling ") empty-        UpToDate-            | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping  ") empty-            | otherwise -> return ()-        RecompBecause reason -> showMsg (text "Compiling ") (text " [" <> text reason <> text "]")+batchMsg hsc_env mod_index recomp node = case node of+    InstantiationNode _ ->+        case recomp of+            MustCompile -> showMsg (text "Instantiating ") empty+            UpToDate+                | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping  ") empty+                | otherwise -> return ()+            RecompBecause reason -> showMsg (text "Instantiating ") (text " [" <> text reason <> text "]")+    ModuleNode _ ->+        case recomp of+            MustCompile -> showMsg (text "Compiling ") empty+            UpToDate+                | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping  ") empty+                | otherwise -> return ()+            RecompBecause reason -> showMsg (text "Compiling ") (text " [" <> text reason <> text "]")     where         dflags = hsc_dflags hsc_env         showMsg msg reason =             compilationProgressMsg dflags $             (showModuleIndex mod_index <>-            msg <> showModMsg dflags (recompileRequired recomp) mod_summary)+            msg <> showModMsg dflags (recompileRequired recomp) node)                 <> reason  --------------------------------------------------------------@@ -1258,6 +1275,7 @@   where     isModSafe :: HomeUnit -> Module -> SrcSpan -> Hsc (Bool, Set UnitId)     isModSafe home_unit m l = do+        hsc_env <- getHscEnv         dflags <- getDynFlags         iface <- lookup' m         case iface of@@ -1273,7 +1291,7 @@                     -- check module is trusted                     safeM = trust `elem` [Sf_Safe, Sf_SafeInferred, Sf_Trustworthy]                     -- check package is trusted-                    safeP = packageTrusted dflags home_unit trust trust_own_pkg m+                    safeP = packageTrusted dflags (hsc_units hsc_env) home_unit trust trust_own_pkg m                     -- pkg trust reqs                     pkgRs = S.fromList . map fst $ filter snd $ dep_pkgs $ mi_deps iface'                     -- warn if Safe module imports Safe-Inferred module.@@ -1293,7 +1311,7 @@                     return (trust == Sf_Trustworthy, pkgRs)                  where-                    state = unitState dflags+                    state = hsc_units hsc_env                     inferredImportWarn = unitBag                         $ makeIntoWarning (Reason Opt_WarnInferredSafeImports)                         $ mkWarnMsg dflags l (pkgQual state)@@ -1318,17 +1336,17 @@     -- modules are trusted without requiring that their package is trusted. For     -- trustworthy modules, modules in the home package are trusted but     -- otherwise we check the package trust flag.-    packageTrusted :: DynFlags -> HomeUnit -> SafeHaskellMode -> Bool -> Module -> Bool-    packageTrusted _ _ Sf_None      _ _ = False -- shouldn't hit these cases-    packageTrusted _ _ Sf_Ignore    _ _ = False -- shouldn't hit these cases-    packageTrusted _ _ Sf_Unsafe    _ _ = False -- prefer for completeness.-    packageTrusted dflags _ _ _ _-        | not (packageTrustOn dflags) = True-    packageTrusted _ _ Sf_Safe  False _ = True-    packageTrusted _ _ Sf_SafeInferred False _ = True-    packageTrusted dflags home_unit _ _ m-        | isHomeModule home_unit m = True-        | otherwise = unitIsTrusted $ unsafeLookupUnit (unitState dflags) (moduleUnit m)+    packageTrusted :: DynFlags -> UnitState -> HomeUnit -> SafeHaskellMode -> Bool -> Module -> Bool+    packageTrusted dflags unit_state home_unit safe_mode trust_own_pkg mod =+        case safe_mode of+            Sf_None      -> False -- shouldn't hit these cases+            Sf_Ignore    -> False -- shouldn't hit these cases+            Sf_Unsafe    -> False -- prefer for completeness.+            _ | not (packageTrustOn dflags)     -> True+            Sf_Safe | not trust_own_pkg         -> True+            Sf_SafeInferred | not trust_own_pkg -> True+            _ | isHomeModule home_unit mod      -> True+            _ -> unitIsTrusted $ unsafeLookupUnit unit_state (moduleUnit m)      lookup' :: Module -> Hsc (Maybe ModIface)     lookup' m = do@@ -1349,8 +1367,9 @@ checkPkgTrust :: Set UnitId -> Hsc () checkPkgTrust pkgs = do     dflags <- getDynFlags+    hsc_env <- getHscEnv     let errors = S.foldr go [] pkgs-        state  = unitState dflags+        state  = hsc_units hsc_env         go pkg acc             | unitIsTrusted $ unsafeLookupUnitId state pkg             = acc@@ -1542,7 +1561,7 @@              (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cg_infos)                 <- {-# SCC "codeOutput" #-}-                  codeOutput dflags this_mod output_filename location+                  codeOutput dflags (hsc_units hsc_env) this_mod output_filename location                   foreign_stubs foreign_files dependencies rawcmms1             return (output_filename, stub_c_exists, foreign_fps, cg_infos) @@ -1575,7 +1594,7 @@     comp_bc <- byteCodeGen hsc_env this_mod prepd_binds data_tycons mod_breaks     ------------------ Create f-x-dynamic C-side stuff -----     (_istub_h_exists, istub_c_exists)-        <- outputForeignStubs dflags this_mod location foreign_stubs+        <- outputForeignStubs dflags (hsc_units hsc_env) this_mod location foreign_stubs     return (istub_c_exists, comp_bc, spt_entries)  ------------------------------@@ -1588,7 +1607,7 @@     cmm <- ioMsgMaybe                $ do                   (warns,errs,cmm) <- withTiming dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ())-                                       $ parseCmmFile dflags filename+                                       $ parseCmmFile dflags home_unit filename                   return ((fmap pprWarning warns, fmap pprError errs), cmm)     liftIO $ do         dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm)@@ -1611,7 +1630,7 @@             FormatCMM (pdoc platform cmmgroup)         rawCmms <- lookupHook (\x -> cmmToRawCmmHook x)                      (\dflgs _ -> cmmToRawCmm dflgs) dflags dflags Nothing (Stream.yield cmmgroup)-        _ <- codeOutput dflags cmm_mod output_filename no_loc NoStubs [] []+        _ <- codeOutput dflags (hsc_units hsc_env) cmm_mod output_filename no_loc NoStubs [] []              rawCmms         return ()   where

@@ -1,5 +1,11 @@-{-# LANGUAGE BangPatterns, CPP, NondecreasingIndentation, ScopedTypeVariables #-}-{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -14,6 +20,7 @@ module GHC.Driver.Make (         depanal, depanalE, depanalPartial,         load, load', LoadHowMuch(..),+        instantiationNodes,          downsweep, @@ -24,11 +31,13 @@         summariseModule,         hscSourceToIsBoot,         findExtraSigImports,-        implicitRequirements,+        implicitRequirementsShallow,          noModError, cyclicModuleErr,         moduleGraphNodes, SummaryNode,-        IsBootInterface(..)+        IsBootInterface(..),++        ModNodeMap(..), emptyModNodeMap, modNodeMapElems, modNodeMapLookup, modNodeMapInsert     ) where  #include "GhclibHsVersions.h"@@ -55,7 +64,9 @@ import GHC.Parser.Header import GHC.Parser.Errors.Ppr +import GHC.Iface.Load      ( cannotFindModule ) import GHC.IfaceToCore     ( typecheckIface )+import GHC.Iface.Recomp    ( RecompileRequired ( MustCompile ) )  import GHC.Data.Bag        ( unitBag, listToBag, unionManyBags, isEmptyBag ) import GHC.Data.Graph.Directed@@ -207,13 +218,37 @@     -- cached finder data.     liftIO $ flushFinderCaches hsc_env -    mod_summariesE <- liftIO $ downsweep hsc_env (mgModSummaries old_graph)-                                     excluded_mods allow_dup_roots+    mod_summariesE <- liftIO $ downsweep+      hsc_env (mgExtendedModSummaries old_graph)+      excluded_mods allow_dup_roots     let-           (errs, mod_summaries) = partitionEithers mod_summariesE-           mod_graph = mkModuleGraph mod_summaries+      (errs, mod_summaries) = partitionEithers mod_summariesE+      mod_graph = mkModuleGraph' $+        fmap ModuleNode mod_summaries ++ instantiationNodes (hsc_units hsc_env)     return (unionManyBags errs, mod_graph) +-- | Collect the instantiations of dependencies to create 'InstantiationNode' work graph nodes.+-- These are used to represent the type checking that is done after+-- all the free holes (sigs in current package) relevant to that instantiation+-- are compiled. This is necessary to catch some instantiation errors.+--+-- In the future, perhaps more of the work of instantiation could be moved here,+-- instead of shoved in with the module compilation nodes. That could simplify+-- backpack, and maybe hs-boot too.+instantiationNodes :: UnitState -> [ModuleGraphNode]+instantiationNodes unit_state = InstantiationNode <$> iuids_to_check+  where+    iuids_to_check :: [InstantiatedUnit]+    iuids_to_check =+      nubSort $ concatMap goUnitId (explicitUnits unit_state)+     where+      goUnitId uid =+        [ recur+        | VirtUnit indef <- [uid]+        , inst <- instUnitInsts indef+        , recur <- (indef :) $ goUnitId $ moduleUnit $ snd inst+        ]+ -- Note [Missing home modules] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Sometimes user doesn't want GHC to pick up modules, not explicitly listed@@ -329,7 +364,7 @@     eps <- liftIO $ hscEPS hsc_env      let dflags = hsc_dflags hsc_env-        state  = unitState dflags+        state  = hsc_units  hsc_env         pit = eps_PIT eps      let loadedPackages@@ -430,7 +465,8 @@     -- upsweep, and for removing from hpt all the modules     -- not in strict downwards closure, during calls to compile.     let mg2_with_srcimps :: [SCC ModSummary]-        mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing+        mg2_with_srcimps = filterToposortToModules $+          topSortModuleGraph True mod_graph Nothing      -- If we can determine that any of the {-# SOURCE #-} imports     -- are definitely unnecessary, then emit a warning.@@ -484,7 +520,8 @@     -- This graph should be cycle-free.     -- If we're restricting the upsweep to a portion of the graph, we     -- also want to retain everything that is still stable.-    let full_mg :: [SCC ModSummary]+    let full_mg, partial_mg0, partial_mg, unstable_mg :: [SCC ModuleGraphNode]+        stable_mg :: [SCC ExtendedModSummary]         full_mg    = topSortModuleGraph False mod_graph Nothing          maybe_top_mod = case how_much of@@ -492,7 +529,6 @@                             LoadDependenciesOf m -> Just m                             _                    -> Nothing -        partial_mg0 :: [SCC ModSummary]         partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod          -- LoadDependenciesOf m: we want the upsweep to stop just@@ -501,15 +537,16 @@         partial_mg             | LoadDependenciesOf _mod <- how_much             = ASSERT( case last partial_mg0 of-                        AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False )+                        AcyclicSCC (ModuleNode (ExtendedModSummary ms _)) -> ms_mod_name ms == _mod; _ -> False )               List.init partial_mg0             | otherwise             = partial_mg0          stable_mg =-            [ AcyclicSCC ms-            | AcyclicSCC ms <- full_mg,-              stable_mod_summary ms ]+            [ AcyclicSCC ems+            | AcyclicSCC (ModuleNode ems@(ExtendedModSummary ms _)) <- full_mg+            , stable_mod_summary ms+            ]          stable_mod_summary ms =           ms_mod_name ms `elementOfUniqSet` stable_obj ||@@ -519,12 +556,13 @@         -- NB. also keep cycles, we need to emit an error message later         unstable_mg = filter not_stable partial_mg           where not_stable (CyclicSCC _) = True-                not_stable (AcyclicSCC ms)+                not_stable (AcyclicSCC (InstantiationNode _)) = True+                not_stable (AcyclicSCC (ModuleNode (ExtendedModSummary ms _)))                    = not $ stable_mod_summary ms          -- Load all the stable modules first, before attempting to load         -- an unstable module (#7231).-        mg = stable_mg ++ unstable_mg+        mg = fmap (fmap ModuleNode) stable_mg ++ unstable_mg      -- clean up between compilations     let cleanup = cleanCurrentModuleTempFiles . hsc_dflags@@ -545,7 +583,8 @@     -- available; this should equal the domain of hpt3.     -- Get in in a roughly top .. bottom order (hence reverse). -    let modsDone = reverse modsUpswept+    let nodesDone = reverse modsUpswept+        (_, modsDone) = partitionNodes nodesDone      -- Try and do linking in some form, depending on whether the     -- upsweep was completely or only partially successful.@@ -569,12 +608,13 @@           let ofile = outputFile dflags           let no_hs_main = gopt Opt_NoHsMain dflags           let-            main_mod = mainModIs dflags+            main_mod = mainModIs hsc_env             a_root_is_Main = mgElemModule mod_graph main_mod             do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib            -- link everything together-          linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1)+          unit_env <- hsc_unit_env <$> getSession+          linkresult <- liftIO $ link (ghcLink dflags) dflags unit_env do_linking (hsc_HPT hsc_env1)            if ghcLink dflags == LinkBinary && isJust ofile && not do_linking              then do@@ -595,12 +635,13 @@        do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.")            let modsDone_names-                 = map ms_mod modsDone+                 = map (ms_mod . emsModSummary) modsDone           let mods_to_zap_names                  = findPartiallyCompletedCycles modsDone_names                       mg2_with_srcimps           let (mods_to_clean, mods_to_keep) =-                partition ((`Set.member` mods_to_zap_names).ms_mod) modsDone+                partition ((`Set.member` mods_to_zap_names).ms_mod) $+                emsModSummary <$> modsDone           hsc_env1 <- getSession           let hpt4 = hsc_HPT hsc_env1               -- We must change the lifetime to TFL_CurrentModule for any temp@@ -632,11 +673,20 @@           ASSERT( just_linkables ) do            -- Link everything together-          linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt5+          unit_env <- hsc_unit_env <$> getSession+          linkresult <- liftIO $ link (ghcLink dflags) dflags unit_env False hpt5            modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt5 }           loadFinish Failed linkresult +partitionNodes+  :: [ModuleGraphNode]+  -> ( [InstantiatedUnit]+     , [ExtendedModSummary]+     )+partitionNodes ns = partitionEithers $ flip fmap ns $ \case+  InstantiationNode x -> Left x+  ModuleNode x -> Right x  -- | Finish up after a load. loadFinish :: GhcMonad m => SuccessFlag -> SuccessFlag -> m SuccessFlag@@ -691,7 +741,7 @@         !mod_graph = hsc_mod_graph env         mainModuleSrcPath :: Maybe String         mainModuleSrcPath = do-            ms <- mgLookupModule mod_graph (mainModIs dflags)+            ms <- mgLookupModule mod_graph (mainModIs env)             ml_hs_file (ms_location ms)         name = fmap dropExtension mainModuleSrcPath @@ -936,11 +986,11 @@  -- | The graph of modules to compile and their corresponding result 'MVar' and -- 'LogQueue'.-type CompilationGraph = [(ModSummary, MVar SuccessFlag, LogQueue)]+type CompilationGraph = [(ModuleGraphNode, MVar SuccessFlag, LogQueue)]  -- | Build a 'CompilationGraph' out of a list of strongly-connected modules, -- also returning the first, if any, encountered module cycle.-buildCompGraph :: [SCC ModSummary] -> IO (CompilationGraph, Maybe [ModSummary])+buildCompGraph :: [SCC ModuleGraphNode] -> IO (CompilationGraph, Maybe [ModuleGraphNode]) buildCompGraph [] = return ([], Nothing) buildCompGraph (scc:sccs) = case scc of     AcyclicSCC ms -> do@@ -958,7 +1008,8 @@ -- We need to treat boot modules specially when building compilation graphs, -- since they break cycles. Regular source files and signature files are treated -- equivalently.-type BuildModule = ModuleWithIsBoot+data BuildModule = BuildModule_Unit {-# UNPACK #-} !InstantiatedUnit | BuildModule_Module {-# UNPACK #-} !ModuleWithIsBoot+  deriving (Eq, Ord)  -- | Tests if an 'HscSource' is a boot file, primarily for constructing elements -- of 'BuildModule'. We conflate signatures and modules because they are bound@@ -968,14 +1019,24 @@ hscSourceToIsBoot HsBootFile = IsBoot hscSourceToIsBoot _ = NotBoot -mkBuildModule :: ModSummary -> BuildModule-mkBuildModule ms = GWIB+mkBuildModule :: ModuleGraphNode -> BuildModule+mkBuildModule = \case+  InstantiationNode x -> BuildModule_Unit x+  ModuleNode ems -> BuildModule_Module $ mkBuildModule0 (emsModSummary ems)++mkHomeBuildModule :: ModuleGraphNode -> NodeKey+mkHomeBuildModule = \case+  InstantiationNode x -> NodeKey_Unit x+  ModuleNode ems -> NodeKey_Module $ mkHomeBuildModule0 (emsModSummary ems)++mkBuildModule0 :: ModSummary -> ModuleWithIsBoot+mkBuildModule0 ms = GWIB   { gwib_mod = ms_mod ms   , gwib_isBoot = isBootSummary ms   } -mkHomeBuildModule :: ModSummary -> ModuleNameWithIsBoot-mkHomeBuildModule ms = GWIB+mkHomeBuildModule0 :: ModSummary -> ModuleNameWithIsBoot+mkHomeBuildModule0 ms = GWIB   { gwib_mod = moduleName $ ms_mod ms   , gwib_isBoot = isBootSummary ms   }@@ -991,16 +1052,13 @@     -> HomePackageTable     -> StableModules     -> (HscEnv -> IO ())-    -> [SCC ModSummary]+    -> [SCC ModuleGraphNode]     -> m (SuccessFlag,-          [ModSummary])+          [ModuleGraphNode]) parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do     hsc_env <- getSession     let dflags = hsc_dflags hsc_env -    when (not (null (instantiatedUnitsToCheck dflags))) $-      throwGhcException (ProgramError "Backpack typechecking not supported with -j")-     -- The bits of shared state we'll be using:      -- The global HscEnv is updated with the module's HMI when a module@@ -1046,16 +1104,19 @@     -- NB: For convenience, the last module of each loop (aka the module that     -- finishes the loop) is prepended to the beginning of the loop.     let graph = map fstOf3 (reverse comp_graph)-        boot_modules = mkModuleSet [ms_mod ms | ms <- graph, isBootSummary ms == IsBoot]+        boot_modules = mkModuleSet+          [ms_mod ms | ModuleNode (ExtendedModSummary ms _) <- graph, isBootSummary ms == IsBoot]         comp_graph_loops = go graph boot_modules           where             remove ms bm = case isBootSummary ms of               IsBoot -> delModuleSet bm (ms_mod ms)               NotBoot -> bm             go [] _ = []-            go mg@(ms:mss) boot_modules+            go (InstantiationNode _ : mss) boot_modules+              = go mss boot_modules+            go mg@(mnode@(ModuleNode (ExtendedModSummary ms _)) : mss) boot_modules               | Just loop <- getModLoop ms mg (`elemModuleSet` boot_modules)-              = map mkBuildModule (ms:loop) : go mss (remove ms boot_modules)+              = map mkBuildModule (mnode : loop) : go mss (remove ms boot_modules)               | otherwise               = go mss (remove ms boot_modules) @@ -1072,12 +1133,20 @@     -- compile this module.     let { spawnWorkers = forM comp_graph_w_idx $ \((mod,!mvar,!log_queue),!mod_idx) ->             forkIOWithUnmask $ \unmask -> do-                liftIO $ label_self $ unwords-                    [ "worker --make thread"-                    , "for module"-                    , show (moduleNameString (ms_mod_name mod))-                    , "number"-                    , show mod_idx+                liftIO $ label_self $ unwords $ concat+                    [ [ "worker --make thread" ]+                    , case mod of+                        InstantiationNode iuid ->+                          [ "for instantiation of unit"+                          , show $ VirtUnit iuid+                          ]+                        ModuleNode ems ->+                          [ "for module"+                          , show (moduleNameString (ms_mod_name (emsModSummary ems)))+                          ]+                    , ["number"+                      , show mod_idx+                      ]                     ]                 -- Replace the default log_action with one that writes each                 -- message to the module's log_queue. The main thread will@@ -1095,11 +1164,17 @@                 -- Unmask asynchronous exceptions and perform the thread-local                 -- work to compile the module (see parUpsweep_one).                 m_res <- MC.try $ unmask $ prettyPrintGhcErrors lcl_dflags $-                        parUpsweep_one mod home_mod_map comp_graph_loops-                                       lcl_dflags (hsc_home_unit hsc_env)-                                       mHscMessage cleanup-                                       par_sem hsc_env_var old_hpt_var-                                       stable_mods mod_idx (length sccs)+                  case mod of+                    InstantiationNode iuid -> do+                      hsc_env <- readMVar hsc_env_var+                      liftIO $ upsweep_inst hsc_env mHscMessage mod_idx (length sccs) iuid+                      pure Succeeded+                    ModuleNode ems ->+                      parUpsweep_one (emsModSummary ems) home_mod_map comp_graph_loops+                                     lcl_dflags (hsc_home_unit hsc_env)+                                     mHscMessage cleanup+                                     par_sem hsc_env_var old_hpt_var+                                     stable_mods mod_idx (length sccs)                  res <- case m_res of                     Right flag -> return flag@@ -1222,7 +1297,7 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags home_unit mHscMessage cleanup par_sem                hsc_env_var old_hpt_var stable_mods mod_index num_mods = do -    let this_build_mod = mkBuildModule mod+    let this_build_mod = mkBuildModule0 mod      let home_imps     = map unLoc $ ms_home_imps mod     let home_src_imps = map unLoc $ ms_home_srcimps mod@@ -1231,7 +1306,7 @@     let textual_deps = Set.fromList $             zipWith f home_imps     (repeat NotBoot) ++             zipWith f home_src_imps (repeat IsBoot)-          where f mn isBoot = GWIB+          where f mn isBoot = BuildModule_Module $ GWIB                   { gwib_mod = mkHomeModule home_unit mn                   , gwib_isBoot = isBoot                   }@@ -1265,29 +1340,36 @@      -- The loop that this module will finish. After this module successfully     -- compiles, this loop is going to get re-typechecked.-    let finish_loop = listToMaybe-            [ tail loop | loop <- comp_graph_loops-                        , head loop == this_build_mod ]+    let finish_loop :: Maybe [ModuleWithIsBoot]+        finish_loop = listToMaybe+          [ flip mapMaybe (tail loop) $ \case+              BuildModule_Unit _ -> Nothing+              BuildModule_Module ms -> Just ms+          | loop <- comp_graph_loops+          , head loop == BuildModule_Module this_build_mod+          ]      -- If this module finishes a loop then it must depend on all the other     -- modules in that loop because the entire module loop is going to be     -- re-typechecked once this module gets compiled. These extra dependencies     -- are this module's "internal" loop dependencies, because this module is     -- inside the loop in question.-    let int_loop_deps = Set.fromList $+    let int_loop_deps :: Set.Set BuildModule+        int_loop_deps = Set.fromList $             case finish_loop of                 Nothing   -> []-                Just loop -> filter (/= this_build_mod) loop+                Just loop -> BuildModule_Module <$> filter (/= this_build_mod) loop      -- If this module depends on a module within a loop then it must wait for     -- that loop to get re-typechecked, i.e. it must wait on the module that     -- finishes that loop. These extra dependencies are this module's     -- "external" loop dependencies, because this module is outside of the     -- loop(s) in question.-    let ext_loop_deps = Set.fromList+    let ext_loop_deps :: Set.Set BuildModule+        ext_loop_deps = Set.fromList             [ head loop | loop <- comp_graph_loops                         , any (`Set.member` textual_deps) loop-                        , this_build_mod `notElem` loop ]+                        , BuildModule_Module this_build_mod `notElem` loop ]       let all_deps = foldl1 Set.union [textual_deps, int_loop_deps, ext_loop_deps]@@ -1295,7 +1377,8 @@     -- All of the module's home-module dependencies.     let home_deps_with_idx =             [ home_dep | dep <- Set.toList all_deps-                       , Just home_dep <- [Map.lookup dep home_mod_map] ]+                       , Just home_dep <- [Map.lookup dep home_mod_map]+                       ]      -- Sort the list of dependencies in reverse-topological order. This way, by     -- the time we get woken up by the result of an earlier dependency,@@ -1398,14 +1481,14 @@ -- There better had not be any cyclic groups here -- we check for them. upsweep     :: forall m-     . GhcMonad m+    .  GhcMonad m     => Maybe Messager     -> HomePackageTable            -- ^ HPT from last time round (pruned)     -> StableModules               -- ^ stable modules (see checkStability)     -> (HscEnv -> IO ())           -- ^ How to clean up unwanted tmp files-    -> [SCC ModSummary]            -- ^ Mods to do (the worklist)+    -> [SCC ModuleGraphNode]       -- ^ Mods to do (the worklist)     -> m (SuccessFlag,-          [ModSummary])+          [ModuleGraphNode])        -- ^ Returns:        --        --  1. A flag whether the complete upsweep was successful.@@ -1413,58 +1496,63 @@        --  3. A list of modules which succeeded loading.  upsweep mHscMessage old_hpt stable_mods cleanup sccs = do-   dflags <- getSessionDynFlags    (res, done) <- upsweep' old_hpt emptyMG sccs 1 (length sccs)-                           (instantiatedUnitsToCheck dflags) done_holes-   return (res, reverse $ mgModSummaries done)+   return (res, reverse $ mgModSummaries' done)  where-  done_holes = emptyUniqSet--  keep_going this_mods old_hpt done mods mod_index nmods uids_to_check done_holes = do-    let sum_deps ms (AcyclicSCC mod) =-          if any (flip elem $ unfilteredEdges False mod) ms-            then mkHomeBuildModule mod:ms-            else ms+  keep_going+    :: [NodeKey]+    -> HomePackageTable+    -> ModuleGraph+    -> [SCC ModuleGraphNode]+    -> Int+    -> Int+    -> m (SuccessFlag, ModuleGraph)+  keep_going this_mods old_hpt done mods mod_index nmods = do+    let sum_deps ms (AcyclicSCC iuidOrMod) =+          if any (flip elem $ unfilteredEdges False iuidOrMod) $ ms+          then mkHomeBuildModule iuidOrMod : ms+          else ms         sum_deps ms _ = ms         dep_closure = foldl' sum_deps this_mods mods         dropped_ms = drop (length this_mods) (reverse dep_closure)-        prunable (AcyclicSCC mod) = elem (mkHomeBuildModule mod) dep_closure+        prunable (AcyclicSCC node) = elem (mkHomeBuildModule node) dep_closure         prunable _ = False         mods' = filter (not . prunable) mods         nmods' = nmods - length dropped_ms      when (not $ null dropped_ms) $ do         dflags <- getSessionDynFlags-        liftIO $ fatalErrorMsg dflags (keepGoingPruneErr $ gwib_mod <$> dropped_ms)-    (_, done') <- upsweep' old_hpt done mods' (mod_index+1) nmods' uids_to_check done_holes+        liftIO $ fatalErrorMsg dflags (keepGoingPruneErr $ dropped_ms)+    (_, done') <- upsweep' old_hpt done mods' (mod_index+1) nmods'     return (Failed, done')    upsweep'     :: HomePackageTable     -> ModuleGraph-    -> [SCC ModSummary]+    -> [SCC ModuleGraphNode]     -> Int     -> Int-    -> [Unit]-    -> UniqSet ModuleName     -> m (SuccessFlag, ModuleGraph)   upsweep' _old_hpt done-     [] _ _ uids_to_check _-   = do hsc_env <- getSession-        liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnit hsc_env) uids_to_check-        return (Succeeded, done)+     [] _ _+     = return (Succeeded, done)    upsweep' _old_hpt done-     (CyclicSCC ms:mods) mod_index nmods uids_to_check done_holes+     (CyclicSCC ms : mods) mod_index nmods    = do dflags <- getSessionDynFlags         liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms)         if gopt Opt_KeepGoing dflags           then keep_going (mkHomeBuildModule <$> ms) old_hpt done mods mod_index nmods-                          uids_to_check done_holes           else return (Failed, done)    upsweep' old_hpt done-     (AcyclicSCC mod:mods) mod_index nmods uids_to_check done_holes+     (AcyclicSCC (InstantiationNode iuid) : mods) mod_index nmods+   = do hsc_env <- getSession+        liftIO $ upsweep_inst hsc_env mHscMessage mod_index nmods iuid+        upsweep' old_hpt done mods (mod_index+1) nmods++  upsweep' old_hpt done+     (AcyclicSCC (ModuleNode ems@(ExtendedModSummary mod _)) : mods) mod_index nmods    = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++         --           show (map (moduleUserString.moduleName.mi_module.hm_iface)         --                     (moduleEnvElts (hsc_HPT hsc_env)))@@ -1472,18 +1560,6 @@          hsc_env <- getSession -        -- TODO: Cache this, so that we don't repeatedly re-check-        -- our imports when you run --make.-        let (ready_uids, uids_to_check')-                = partition (\uid -> isEmptyUniqDSet-                    (unitFreeModuleHoles uid `uniqDSetMinusUniqSet` done_holes))-                     uids_to_check-            done_holes'-                | ms_hsc_src mod == HsigFile-                = addOneToUniqSet done_holes (ms_mod_name mod)-                | otherwise = done_holes-        liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnit hsc_env) ready_uids-         -- Remove unwanted tmp files between compilations         liftIO (cleanup hsc_env) @@ -1513,8 +1589,7 @@           Nothing -> do                 dflags <- getSessionDynFlags                 if gopt Opt_KeepGoing dflags-                  then keep_going [mkHomeBuildModule mod] old_hpt done mods mod_index nmods-                                  uids_to_check done_holes+                  then keep_going [NodeKey_Module $ mkHomeBuildModule0 mod] old_hpt done mods mod_index nmods                   else return (Failed, done)           Just mod_info -> do                 let this_mod = ms_mod_name mod@@ -1534,7 +1609,7 @@                       IsBoot -> old_hpt                       NotBoot -> delFromHpt old_hpt this_mod -                    done' = extendMG done mod+                    done' = extendMG done ems                          -- fixup our HomePackageTable after we've finished compiling                         -- a mutually-recursive loop.  We have to do this again@@ -1556,19 +1631,7 @@                                  , spt <- spts                                  ] -                upsweep' old_hpt1 done' mods (mod_index+1) nmods uids_to_check' done_holes'---- | Return a list of instantiated units to type check from the UnitState.------ Use explicit (instantiated) units as roots and also return their--- instantiations that are themselves instantiations and so on recursively.-instantiatedUnitsToCheck :: DynFlags -> [Unit]-instantiatedUnitsToCheck dflags =-  nubSort $ concatMap goUnit (explicitUnits (unitState dflags))- where-  goUnit HoleUnit         = []-  goUnit (RealUnit _)     = []-  goUnit uid@(VirtUnit i) = uid : concatMap (goUnit . moduleUnit . snd) (instUnitInsts i)+                upsweep' old_hpt1 done' mods (mod_index+1) nmods  maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime) maybeGetIfaceDate dflags location@@ -1579,6 +1642,19 @@  | otherwise     = return Nothing +upsweep_inst :: HscEnv+             -> Maybe Messager+             -> Int  -- index of module+             -> Int  -- total number of modules+             -> InstantiatedUnit+             -> IO ()+upsweep_inst hsc_env mHscMessage mod_index nmods iuid = do+        case mHscMessage of+            Just hscMessage -> hscMessage hsc_env (mod_index, nmods) MustCompile (InstantiationNode iuid)+            Nothing -> return ()+        runHsc hsc_env $ ioMsgMaybe $ tcRnCheckUnit hsc_env $ VirtUnit iuid+        pure ()+ -- | Compile a single module.  Always produce a Linkable for it if -- successful.  If no compilation happened, return the old Linkable. upsweep_mod :: HscEnv@@ -1864,13 +1940,17 @@   | Just loop <- getModLoop ms mss appearsAsBoot   -- SOME hs-boot files should still   -- get used, just not the loop-closer.-  , let non_boot = filter (\l -> not (isBootSummary l == IsBoot &&-                                 ms_mod l == ms_mod ms)) loop+  , let non_boot = flip mapMaybe loop $ \case+          InstantiationNode _ -> Nothing+          ModuleNode ems -> do+            let l = emsModSummary ems+            guard $ not $ isBootSummary l == IsBoot && ms_mod l == ms_mod ms+            pure l   = typecheckLoop (hsc_dflags hsc_env) hsc_env (map ms_mod_name non_boot)   | otherwise   = return hsc_env   where-  mss = mgModSummaries graph+  mss = mgModSummaries' graph   appearsAsBoot = (`elemModuleSet` mgBootModules graph)  -- | Given a non-boot ModSummary @ms@ of a module, for which there exists a@@ -1911,9 +1991,9 @@ -- getModLoop   :: ModSummary-  -> [ModSummary]+  -> [ModuleGraphNode]   -> (Module -> Bool) -- check if a module appears as a boot module in 'graph'-  -> Maybe [ModSummary]+  -> Maybe [ModuleGraphNode] getModLoop ms graph appearsAsBoot   | isBootSummary ms == NotBoot   , appearsAsBoot this_mod@@ -1944,12 +2024,12 @@     old_hpt = hsc_HPT hsc_env     hmis    = map (expectJust "typecheckLoop" . lookupHpt old_hpt) mods -reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary]+reachableBackwards :: ModuleName -> [ModuleGraphNode] -> [ModuleGraphNode] reachableBackwards mod summaries   = [ node_payload node | node <- reachableG (transposeG graph) root ]   where -- the rest just sets up the graph:         (graph, lookup_node) = moduleGraphNodes False summaries-        root  = expectJust "reachableBackwards" (lookup_node $ GWIB mod IsBoot)+        root  = expectJust "reachableBackwards" (lookup_node $ NodeKey_Module $ GWIB mod IsBoot)  -- --------------------------------------------------------------------------- --@@ -1960,7 +2040,7 @@           -> ModuleGraph           -> Maybe ModuleName              -- ^ Root module name.  If @Nothing@, use the full graph.-          -> [SCC ModSummary]+          -> [SCC ModuleGraphNode] -- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes -- The resulting list of strongly-connected-components is in topologically -- sorted order, starting with the module(s) at the bottom of the@@ -1979,7 +2059,7 @@ topSortModuleGraph drop_hs_boot_nodes module_graph mb_root_mod   = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph   where-    summaries = mgModSummaries module_graph+    summaries = mgModSummaries' module_graph     -- stronglyConnCompG flips the original order, so if we reverse     -- the summaries we get a stable topological sort.     (graph, lookup_node) =@@ -1992,22 +2072,22 @@             -- the specified module.  We do this by building a graph with             -- the full set of nodes, and determining the reachable set from             -- the specified node.-            let root | Just node <- lookup_node $ GWIB root_mod NotBoot+            let root | Just node <- lookup_node $ NodeKey_Module $ GWIB root_mod NotBoot                      , graph `hasVertexG` node                      = node                      | otherwise                      = throwGhcException (ProgramError "module does not exist")             in graphFromEdgedVerticesUniq (seq root (reachableG graph root)) -type SummaryNode = Node Int ModSummary+type SummaryNode = Node Int ModuleGraphNode  summaryNodeKey :: SummaryNode -> Int summaryNodeKey = node_key -summaryNodeSummary :: SummaryNode -> ModSummary+summaryNodeSummary :: SummaryNode -> ModuleGraphNode summaryNodeSummary = node_payload --- | Collect the immediate dependencies of a module from its ModSummary,+-- | Collect the immediate dependencies of a ModuleGraphNode, -- optionally avoiding hs-boot dependencies. -- If the drop_hs_boot_nodes flag is False, and if this is a .hs and there is -- an equivalent .hs-boot, add a link from the former to the latter.  This@@ -2015,69 +2095,103 @@ -- .hs, by introducing a cycle.  Additionally, it ensures that we will always -- process the .hs-boot before the .hs, and so the HomePackageTable will always -- have the most up to date information.-unfilteredEdges :: Bool -> ModSummary -> [ModuleNameWithIsBoot]-unfilteredEdges drop_hs_boot_nodes ms =-    (flip GWIB hs_boot_key . unLoc <$> ms_home_srcimps ms) ++-    (flip GWIB NotBoot     . unLoc <$> ms_home_imps ms) ++-    [ GWIB (ms_mod_name ms) IsBoot-    | not $ drop_hs_boot_nodes || ms_hsc_src ms == HsBootFile-    ]+unfilteredEdges :: Bool -> ModuleGraphNode -> [NodeKey]+unfilteredEdges drop_hs_boot_nodes = \case+    InstantiationNode iuid ->+      NodeKey_Module . flip GWIB NotBoot <$> uniqDSetToList (instUnitHoles iuid)+    ModuleNode (ExtendedModSummary ms bds) ->+      (NodeKey_Module . flip GWIB hs_boot_key . unLoc <$> ms_home_srcimps ms) +++      (NodeKey_Module . flip GWIB NotBoot     . unLoc <$> ms_home_imps ms) +++      [ NodeKey_Module $ GWIB (ms_mod_name ms) IsBoot+      | not $ drop_hs_boot_nodes || ms_hsc_src ms == HsBootFile+      ] +++      [ NodeKey_Unit inst_unit+      | inst_unit <- bds+      ]   where     -- Drop hs-boot nodes by using HsSrcFile as the key     hs_boot_key | drop_hs_boot_nodes = NotBoot -- is regular mod or signature                 | otherwise          = IsBoot -moduleGraphNodes :: Bool -> [ModSummary]-  -> (Graph SummaryNode, ModuleNameWithIsBoot -> Maybe SummaryNode)+moduleGraphNodes :: Bool -> [ModuleGraphNode]+  -> (Graph SummaryNode, NodeKey -> Maybe SummaryNode) moduleGraphNodes drop_hs_boot_nodes summaries =   (graphFromEdgedVerticesUniq nodes, lookup_node)   where     numbered_summaries = zip summaries [1..] -    lookup_node :: ModuleNameWithIsBoot -> Maybe SummaryNode-    lookup_node mnwib = Map.lookup mnwib node_map+    lookup_node :: NodeKey -> Maybe SummaryNode+    lookup_node key = Map.lookup key (unNodeMap node_map) -    lookup_key :: ModuleNameWithIsBoot -> Maybe Int+    lookup_key :: NodeKey -> Maybe Int     lookup_key = fmap summaryNodeKey . lookup_node      node_map :: NodeMap SummaryNode-    node_map = Map.fromList [ (mkHomeBuildModule s, node)-                            | node <- nodes-                            , let s = summaryNodeSummary node-                            ]+    node_map = NodeMap $+      Map.fromList [ (mkHomeBuildModule s, node)+                   | node <- nodes+                   , let s = summaryNodeSummary node+                   ]      -- We use integers as the keys for the SCC algorithm     nodes :: [SummaryNode]     nodes = [ DigraphNode s key $ out_edge_keys $ unfilteredEdges drop_hs_boot_nodes s             | (s, key) <- numbered_summaries              -- Drop the hi-boot ones if told to do so-            , not (isBootSummary s == IsBoot && drop_hs_boot_nodes)+            , case s of+                InstantiationNode _ -> True+                ModuleNode ems -> not $ isBootSummary (emsModSummary ems) == IsBoot && drop_hs_boot_nodes             ] -    out_edge_keys :: [ModuleNameWithIsBoot] -> [Int]+    out_edge_keys :: [NodeKey] -> [Int]     out_edge_keys = mapMaybe lookup_key         -- If we want keep_hi_boot_nodes, then we do lookup_key with         -- IsBoot; else False --- The nodes of the graph are keyed by (mod, is boot?) pairs+-- The nodes of the graph are keyed by (mod, is boot?) pairs for the current+-- modules, and indefinite unit IDs for dependencies which are instantiated with+-- our holes.+-- -- NB: hsig files show up as *normal* nodes (not boot!), since they don't -- participate in cycles (for now)-type NodeKey   = ModuleNameWithIsBoot-type NodeMap a = Map.Map NodeKey a+type ModNodeKey = ModuleNameWithIsBoot+newtype ModNodeMap a = ModNodeMap { unModNodeMap :: Map.Map ModNodeKey a }+  deriving (Functor, Traversable, Foldable) -msKey :: ModSummary -> NodeKey-msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot })-    = GWIB-        { gwib_mod = moduleName mod-        , gwib_isBoot = hscSourceToIsBoot boot-        }+emptyModNodeMap :: ModNodeMap a+emptyModNodeMap = ModNodeMap Map.empty -mkNodeMap :: [ModSummary] -> NodeMap ModSummary-mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries]+modNodeMapInsert :: ModNodeKey -> a -> ModNodeMap a -> ModNodeMap a+modNodeMapInsert k v (ModNodeMap m) = ModNodeMap (Map.insert k v m) -nodeMapElts :: NodeMap a -> [a]-nodeMapElts = Map.elems+modNodeMapElems :: ModNodeMap a -> [a]+modNodeMapElems (ModNodeMap m) = Map.elems m +modNodeMapLookup :: ModNodeKey -> ModNodeMap a -> Maybe a+modNodeMapLookup k (ModNodeMap m) = Map.lookup k m++data NodeKey = NodeKey_Unit {-# UNPACK #-} !InstantiatedUnit | NodeKey_Module {-# UNPACK #-} !ModNodeKey+  deriving (Eq, Ord)++newtype NodeMap a = NodeMap { unNodeMap :: Map.Map NodeKey a }+  deriving (Functor, Traversable, Foldable)++msKey :: ModSummary -> ModNodeKey+msKey = mkHomeBuildModule0++mkNodeKey :: ModuleGraphNode -> NodeKey+mkNodeKey = \case+  InstantiationNode x -> NodeKey_Unit x+  ModuleNode x -> NodeKey_Module $ mkHomeBuildModule0 (emsModSummary x)++pprNodeKey :: NodeKey -> SDoc+pprNodeKey (NodeKey_Unit iu) = ppr iu+pprNodeKey (NodeKey_Module mk) = ppr mk++mkNodeMap :: [ExtendedModSummary] -> ModNodeMap ExtendedModSummary+mkNodeMap summaries = ModNodeMap $ Map.fromList+  [ (msKey $ emsModSummary s, s) | s <- summaries]+ -- | If there are {-# SOURCE #-} imports between strongly connected -- components in the topological sort, then those imports can -- definitely be replaced by ordinary non-SOURCE imports: if SOURCE@@ -2115,16 +2229,17 @@ -- module, plus one for any hs-boot files.  The imports of these nodes -- are all there, including the imports of non-home-package modules. downsweep :: HscEnv-          -> [ModSummary]       -- Old summaries+          -> [ExtendedModSummary]+          -- ^ Old summaries           -> [ModuleName]       -- Ignore dependencies on these; treat                                 -- them as if they were package modules           -> Bool               -- True <=> allow multiple targets to have                                 --          the same module name; this is                                 --          very useful for ghc -M-          -> IO [Either ErrorMessages ModSummary]-                -- The elts of [ModSummary] all have distinct-                -- (Modules, IsBoot) identifiers, unless the Bool is true-                -- in which case there can be repeats+          -> IO [Either ErrorMessages ExtendedModSummary]+                -- The non-error elements of the returned list all have distinct+                -- (Modules, IsBoot) identifiers, unless the Bool is true in+                -- which case there can be repeats downsweep hsc_env old_summaries excl_mods allow_dup_roots    = do        rootSummaries <- mapM getRootSummary roots@@ -2143,18 +2258,20 @@          Interpreter -> enableCodeGenForUnboxedTuplesOrSums default_backend map0          _           -> return map0        if null errs-         then pure $ concat $ nodeMapElts map1+         then pure $ concat $ modNodeMapElems map1          else pure $ map Left errs      where-        calcDeps = msDeps+        -- TODO(@Ericson2314): Probably want to include backpack instantiations+        -- in the map eventually for uniformity+        calcDeps (ExtendedModSummary ms _bkp_deps) = msDeps ms          dflags = hsc_dflags hsc_env         roots = hsc_targets hsc_env -        old_summary_map :: NodeMap ModSummary+        old_summary_map :: ModNodeMap ExtendedModSummary         old_summary_map = mkNodeMap old_summaries -        getRootSummary :: Target -> IO (Either ErrorMessages ModSummary)+        getRootSummary :: Target -> IO (Either ErrorMessages ExtendedModSummary)         getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf)            = do exists <- liftIO $ doesFileExist file                 if exists || isJust maybe_buf@@ -2176,40 +2293,46 @@         -- name, so we have to check that there aren't multiple root files         -- defining the same module (otherwise the duplicates will be silently         -- ignored, leading to confusing behaviour).-        checkDuplicates :: NodeMap [Either ErrorMessages ModSummary] -> IO ()+        checkDuplicates+          :: ModNodeMap+               [Either ErrorMessages+                       ExtendedModSummary]+          -> IO ()         checkDuplicates root_map            | allow_dup_roots = return ()            | null dup_roots  = return ()-           | otherwise       = liftIO $ multiRootsErr dflags (head dup_roots)+           | otherwise       = liftIO $ multiRootsErr dflags (emsModSummary <$> head dup_roots)            where-             dup_roots :: [[ModSummary]]        -- Each at least of length 2-             dup_roots = filterOut isSingleton $ map rights $ nodeMapElts root_map+             dup_roots :: [[ExtendedModSummary]]        -- Each at least of length 2+             dup_roots = filterOut isSingleton $ map rights $ modNodeMapElems root_map          loop :: [GenWithIsBoot (Located ModuleName)]                         -- Work list: process these modules-             -> NodeMap [Either ErrorMessages ModSummary]+             -> ModNodeMap [Either ErrorMessages ExtendedModSummary]                         -- Visited set; the range is a list because                         -- the roots can have the same module names                         -- if allow_dup_roots is True-             -> IO (NodeMap [Either ErrorMessages ModSummary])+             -> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])                         -- The result is the completed NodeMap         loop [] done = return done         loop (s : ss) done-          | Just summs <- Map.lookup key done+          | Just summs <- modNodeMapLookup key done           = if isSingleton summs then                 loop ss done             else-                do { multiRootsErr dflags (rights summs); return Map.empty }+                do { multiRootsErr dflags (emsModSummary <$> rights summs)+                   ; return (ModNodeMap Map.empty)+                   }           | otherwise           = do mb_s <- summariseModule hsc_env old_summary_map                                        is_boot wanted_mod True                                        Nothing excl_mods                case mb_s of                    Nothing -> loop ss done-                   Just (Left e) -> loop ss (Map.insert key [Left e] done)+                   Just (Left e) -> loop ss (modNodeMapInsert key [Left e] done)                    Just (Right s)-> do                      new_map <--                       loop (calcDeps s) (Map.insert key [Right s] done)+                       loop (calcDeps s) (modNodeMapInsert key [Right s] done)                      loop ss new_map           where             GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = s@@ -2225,8 +2348,8 @@ -- and .o file locations to be temporary files. -- See Note [-fno-code mode] enableCodeGenForTH :: HomeUnit -> Backend-  -> NodeMap [Either ErrorMessages ModSummary]-  -> IO (NodeMap [Either ErrorMessages ModSummary])+  -> ModNodeMap [Either ErrorMessages ExtendedModSummary]+  -> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary]) enableCodeGenForTH home_unit =   enableCodeGenWhen condition should_modify TFL_CurrentModule TFL_GhcSession   where@@ -2245,8 +2368,8 @@ -- This is used in order to load code that uses unboxed tuples -- or sums into GHCi while still allowing some code to be interpreted. enableCodeGenForUnboxedTuplesOrSums :: Backend-  -> NodeMap [Either ErrorMessages ModSummary]-  -> IO (NodeMap [Either ErrorMessages ModSummary])+  -> ModNodeMap [Either ErrorMessages ExtendedModSummary]+  -> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary]) enableCodeGenForUnboxedTuplesOrSums =   enableCodeGenWhen condition should_modify TFL_GhcSession TFL_CurrentModule   where@@ -2271,12 +2394,13 @@   -> TempFileLifetime   -> TempFileLifetime   -> Backend-  -> NodeMap [Either ErrorMessages ModSummary]-  -> IO (NodeMap [Either ErrorMessages ModSummary])+  -> ModNodeMap [Either ErrorMessages ExtendedModSummary]+  -> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary]) enableCodeGenWhen condition should_modify staticLife dynLife bcknd nodemap =   traverse (traverse (traverse enable_code_gen)) nodemap   where-    enable_code_gen ms+    enable_code_gen :: ExtendedModSummary -> IO ExtendedModSummary+    enable_code_gen (ExtendedModSummary ms bkp_deps)       | ModSummary         { ms_mod = ms_mod         , ms_location = ms_location@@ -2302,22 +2426,23 @@             then return (ml_hi_file ms_location, ml_obj_file ms_location)             else (,) <$> (new_temp_file (hiSuf_ dflags) (dynHiSuf_ dflags))                      <*> (new_temp_file (objectSuf_ dflags) (dynObjectSuf_ dflags))-        return $-          ms-          { ms_location =-              ms_location {ml_hi_file = hi_file, ml_obj_file = o_file}-          , ms_hspp_opts = updOptLevel 0 $ dflags {backend = bcknd}-          }-      | otherwise = return ms+        let ms' = ms+              { ms_location =+                  ms_location {ml_hi_file = hi_file, ml_obj_file = o_file}+              , ms_hspp_opts = updOptLevel 0 $ dflags {backend = bcknd}+              }+        pure (ExtendedModSummary ms' bkp_deps)+      | otherwise = return (ExtendedModSummary ms bkp_deps)      needs_codegen_set = transitive_deps_set       [ ms-      | mss <- Map.elems nodemap-      , Right ms <- mss+      | mss <- modNodeMapElems nodemap+      , Right (ExtendedModSummary { emsModSummary = ms }) <- mss       , condition ms       ]      -- find the set of all transitive dependencies of a list of modules.+    transitive_deps_set :: [ModSummary] -> Set.Set Module     transitive_deps_set modSums = foldl' go Set.empty modSums       where         go marked_mods ms@ModSummary{ms_mod}@@ -2330,17 +2455,20 @@                   -- means we don't have to think about boot modules here.                   | dep <- msDeps ms                   , NotBoot == gwib_isBoot dep-                  , dep_ms_0 <- toList $ Map.lookup (unLoc <$> dep) nodemap+                  , dep_ms_0 <- toList $ modNodeMapLookup (unLoc <$> dep) nodemap                   , dep_ms_1 <- toList $ dep_ms_0-                  , dep_ms <- toList $ dep_ms_1+                  , (ExtendedModSummary { emsModSummary = dep_ms }) <- toList $ dep_ms_1                   ]                 new_marked_mods = Set.insert ms_mod marked_mods             in foldl' go new_marked_mods deps -mkRootMap :: [ModSummary] -> NodeMap [Either ErrorMessages ModSummary]-mkRootMap summaries = Map.insertListWith (flip (++))-                                         [ (msKey s, [Right s]) | s <- summaries ]-                                         Map.empty+mkRootMap+  :: [ExtendedModSummary]+  -> ModNodeMap [Either ErrorMessages ExtendedModSummary]+mkRootMap summaries = ModNodeMap $ Map.insertListWith+  (flip (++))+  [ (msKey $ emsModSummary s, [Right s]) | s <- summaries ]+  Map.empty  -- | Returns the dependencies of the ModSummary s. -- A wrinkle is that for a {-# SOURCE #-} import we return@@ -2376,12 +2504,12 @@  summariseFile         :: HscEnv-        -> [ModSummary]                 -- old summaries+        -> [ExtendedModSummary]         -- old summaries         -> FilePath                     -- source file name         -> Maybe Phase                  -- start phase         -> Bool                         -- object code allowed?         -> Maybe (StringBuffer,UTCTime)-        -> IO (Either ErrorMessages ModSummary)+        -> IO (Either ErrorMessages ExtendedModSummary)  summariseFile hsc_env old_summaries src_fn mb_phase obj_allowed maybe_buf         -- we can use a cached summary if one is available and the@@ -2389,7 +2517,7 @@         -- by source file, rather than module name as we do in summarise.    | Just old_summary <- findSummaryBySourceFile old_summaries src_fn    = do-        let location = ms_location old_summary+        let location = ms_location $ emsModSummary old_summary             dflags = hsc_dflags hsc_env          src_timestamp <- get_src_timestamp@@ -2438,21 +2566,27 @@             , nms_preimps = preimps             } -findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary-findSummaryBySourceFile summaries file-  = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms],-                                 expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of-        [] -> Nothing-        (x:_) -> Just x+findSummaryBySourceFile :: [ExtendedModSummary] -> FilePath -> Maybe ExtendedModSummary+findSummaryBySourceFile summaries file = case+    [ ms+    | ms <- summaries+    , HsSrcFile <- [ms_hsc_src $ emsModSummary ms]+    , let derived_file = ml_hs_file $ ms_location $ emsModSummary ms+    , expectJust "findSummaryBySourceFile" derived_file == file+    ]+  of+    [] -> Nothing+    (x:_) -> Just x  checkSummaryTimestamp     :: HscEnv -> DynFlags -> Bool -> IsBootInterface-    -> (UTCTime -> IO (Either e ModSummary))-    -> ModSummary -> ModLocation -> UTCTime-    -> IO (Either e ModSummary)+    -> (UTCTime -> IO (Either e ExtendedModSummary))+    -> ExtendedModSummary -> ModLocation -> UTCTime+    -> IO (Either e ExtendedModSummary) checkSummaryTimestamp   hsc_env dflags obj_allowed is_boot new_summary-  old_summary location src_timestamp+  (ExtendedModSummary { emsModSummary = old_summary, emsInstantiatedUnits = bkp_deps})+  location src_timestamp   | ms_hs_date old_summary == src_timestamp &&       not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) = do            -- update the object-file timestamp@@ -2473,11 +2607,15 @@            hi_timestamp <- maybeGetIfaceDate dflags location            hie_timestamp <- modificationTimeIfExists (ml_hie_file location) -           return $ Right old_summary-               { ms_obj_date = obj_timestamp-               , ms_iface_date = hi_timestamp-               , ms_hie_date = hie_timestamp-               }+           return $ Right+             ( ExtendedModSummary { emsModSummary = old_summary+                     { ms_obj_date = obj_timestamp+                     , ms_iface_date = hi_timestamp+                     , ms_hie_date = hie_timestamp+                     }+                   , emsInstantiatedUnits = bkp_deps+                   }+             )     | otherwise =            -- source changed: re-summarise.@@ -2486,25 +2624,26 @@ -- Summarise a module, and pick up source and timestamp. summariseModule           :: HscEnv-          -> NodeMap ModSummary -- Map of old summaries+          -> ModNodeMap ExtendedModSummary+          -- ^ Map of old summaries           -> IsBootInterface    -- True <=> a {-# SOURCE #-} import           -> Located ModuleName -- Imported module to be summarised           -> Bool               -- object code allowed?           -> Maybe (StringBuffer, UTCTime)           -> [ModuleName]               -- Modules to exclude-          -> IO (Maybe (Either ErrorMessages ModSummary))      -- Its new summary+          -> IO (Maybe (Either ErrorMessages ExtendedModSummary))      -- Its new summary  summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)                 obj_allowed maybe_buf excl_mods   | wanted_mod `elem` excl_mods   = return Nothing -  | Just old_summary <- Map.lookup+  | Just old_summary <- modNodeMapLookup       (GWIB { gwib_mod = wanted_mod, gwib_isBoot = is_boot })       old_summary_map   = do          -- Find its new timestamp; all the                 -- ModSummaries in the old map have valid ml_hs_files-        let location = ms_location old_summary+        let location = ms_location $ emsModSummary old_summary             src_fn = expectJust "summariseModule" (ml_hs_file location)                  -- check the modification time on the source file, and@@ -2529,7 +2668,7 @@     check_timestamp old_summary location src_fn =         checkSummaryTimestamp           hsc_env dflags obj_allowed is_boot-          (new_summary location (ms_mod old_summary) src_fn)+          (new_summary location (ms_mod $ emsModSummary old_summary) src_fn)           old_summary location      find_it = do@@ -2626,7 +2765,7 @@       , nms_preimps :: PreprocessedImports       } -makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ModSummary+makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ExtendedModSummary makeNewModSummary hsc_env MakeNewModSummary{..} = do   let PreprocessedImports{..} = nms_preimps   let dflags = hsc_dflags hsc_env@@ -2643,24 +2782,30 @@   hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location)    extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name-  required_by_imports <- implicitRequirements hsc_env pi_theimps+  (implicit_sigs, inst_deps) <- implicitRequirementsShallow hsc_env pi_theimps -  return $ ModSummary-      { ms_mod = nms_mod-      , ms_hsc_src = nms_hsc_src-      , ms_location = nms_location-      , ms_hspp_file = pi_hspp_fn-      , ms_hspp_opts = pi_local_dflags-      , ms_hspp_buf  = Just pi_hspp_buf-      , ms_parsed_mod = Nothing-      , ms_srcimps = pi_srcimps-      , ms_textual_imps =-          pi_theimps ++ extra_sig_imports ++ required_by_imports-      , ms_hs_date = nms_src_timestamp-      , ms_iface_date = hi_timestamp-      , ms_hie_date = hie_timestamp-      , ms_obj_date = obj_timestamp-      }+  return $ ExtendedModSummary+    { emsModSummary =+        ModSummary+        { ms_mod = nms_mod+        , ms_hsc_src = nms_hsc_src+        , ms_location = nms_location+        , ms_hspp_file = pi_hspp_fn+        , ms_hspp_opts = pi_local_dflags+        , ms_hspp_buf  = Just pi_hspp_buf+        , ms_parsed_mod = Nothing+        , ms_srcimps = pi_srcimps+        , ms_textual_imps =+            pi_theimps +++            extra_sig_imports +++            ((,) Nothing . noLoc <$> implicit_sigs)+        , ms_hs_date = nms_src_timestamp+        , ms_iface_date = hi_timestamp+        , ms_hie_date = hie_timestamp+        , ms_obj_date = obj_timestamp+        }+    , emsInstantiatedUnits = inst_deps+    }  getObjTimestamp :: ModLocation -> IsBootInterface -> IO (Maybe UTCTime) getObjTimestamp location is_boot@@ -2740,10 +2885,10 @@       (\_ -> setLogAction (log_action dflags) >> printDeferredDiagnostics)       (\_ -> f) -noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> ErrMsg+noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> ErrMsg -- ToDo: we don't have a proper line number for this error-noModError dflags loc wanted_mod err-  = mkPlainErrMsg dflags loc $ cannotFindModule dflags wanted_mod err+noModError hsc_env loc wanted_mod err+  = mkPlainErrMsg (hsc_dflags hsc_env) loc $ cannotFindModule hsc_env wanted_mod err  noHsFileErr :: DynFlags -> SrcSpan -> String -> ErrorMessages noHsFileErr dflags loc path@@ -2765,42 +2910,64 @@     mod = ms_mod summ1     files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs -keepGoingPruneErr :: [ModuleName] -> SDoc+keepGoingPruneErr :: [NodeKey] -> SDoc keepGoingPruneErr ms   = vcat (( text "-fkeep-going in use, removing the following" <+>             text "dependencies and continuing:"):-          map (nest 6 . ppr) ms )+          map (nest 6 . pprNodeKey) ms ) -cyclicModuleErr :: [ModSummary] -> SDoc+cyclicModuleErr :: [ModuleGraphNode] -> SDoc -- From a strongly connected component we find -- a single cycle to report cyclicModuleErr mss   = ASSERT( not (null mss) )     case findCycle graph of        Nothing   -> text "Unexpected non-cycle" <+> ppr mss-       Just path -> vcat [ text "Module imports form a cycle:"-                         , nest 2 (show_path path) ]+       Just path0 -> vcat+        [ case partitionNodes path0 of+            ([],_) -> text "Module imports form a cycle:"+            (_,[]) -> text "Module instantiations form a cycle:"+            _ -> text "Module imports and instantiations form a cycle:"+        , nest 2 (show_path path0)]   where-    graph :: [Node NodeKey ModSummary]-    graph = [ DigraphNode ms (msKey ms) (get_deps ms) | ms <- mss]+    graph :: [Node NodeKey ModuleGraphNode]+    graph =+      [ DigraphNode+        { node_payload = ms+        , node_key = mkNodeKey ms+        , node_dependencies = get_deps ms+        }+      | ms <- mss+      ] -    get_deps :: ModSummary -> [NodeKey]-    get_deps ms =-      [ GWIB { gwib_mod = unLoc m, gwib_isBoot = IsBoot }-      | m <- ms_home_srcimps ms ] ++-      [ GWIB { gwib_mod = unLoc m, gwib_isBoot = NotBoot }-      | m <- ms_home_imps    ms ]+    get_deps :: ModuleGraphNode -> [NodeKey]+    get_deps = \case+      InstantiationNode iuid ->+        [ NodeKey_Module $ GWIB { gwib_mod = hole, gwib_isBoot = NotBoot }+        | hole <- uniqDSetToList $ instUnitHoles iuid+        ]+      ModuleNode (ExtendedModSummary ms bds) ->+        [ NodeKey_Module $ GWIB { gwib_mod = unLoc m, gwib_isBoot = IsBoot }+        | m <- ms_home_srcimps ms ] +++        [ NodeKey_Module $ GWIB { gwib_mod = unLoc m, gwib_isBoot = NotBoot }+        | m <- ms_home_imps    ms ] +++        [ NodeKey_Unit inst_unit+        | inst_unit <- bds+        ] -    show_path []         = panic "show_path"-    show_path [m]        = text "module" <+> ppr_ms m-                           <+> text "imports itself"-    show_path (m1:m2:ms) = vcat ( nest 7 (text "module" <+> ppr_ms m1)-                                : nest 6 (text "imports" <+> ppr_ms m2)+    show_path :: [ModuleGraphNode] -> SDoc+    show_path []  = panic "show_path"+    show_path [m] = ppr_node m <+> text "imports itself"+    show_path (m1:m2:ms) = vcat ( nest 6 (ppr_node m1)+                                : nest 6 (text "imports" <+> ppr_node m2)                                 : go ms )        where-         go []     = [text "which imports" <+> ppr_ms m1]-         go (m:ms) = (text "which imports" <+> ppr_ms m) : go ms+         go []     = [text "which imports" <+> ppr_node m1]+         go (m:ms) = (text "which imports" <+> ppr_node m) : go ms +    ppr_node :: ModuleGraphNode -> SDoc+    ppr_node (ModuleNode m) = text "module" <+> ppr_ms (emsModSummary m)+    ppr_node (InstantiationNode u) = text "instantiated unit" <+> ppr u      ppr_ms :: ModSummary -> SDoc     ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+>

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}  ----------------------------------------------------------------------------- --@@ -33,6 +34,8 @@ import GHC.Data.FastString import GHC.SysTools.FileCleanup +import GHC.Iface.Load (cannotFindModule)+ import GHC.Unit.Module import GHC.Unit.Module.ModSummary import GHC.Unit.Module.Graph@@ -184,7 +187,7 @@             -> [ModuleName]             -> FilePath             -> Handle           -- Write dependencies to here-            -> SCC ModSummary+            -> SCC ModuleGraphNode             -> IO () -- Write suitable dependencies to handle -- Always:@@ -203,9 +206,17 @@  processDeps dflags _ _ _ _ (CyclicSCC nodes)   =     -- There shouldn't be any cycles; report them-    throwGhcExceptionIO (ProgramError (showSDoc dflags $ GHC.cyclicModuleErr nodes))+    throwGhcExceptionIO $ ProgramError $+      showSDoc dflags $ GHC.cyclicModuleErr nodes -processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC node)+processDeps dflags _ _ _ _ (AcyclicSCC (InstantiationNode node))+  =     -- There shouldn't be any backpack instantiations; report them as well+    throwGhcExceptionIO $ ProgramError $+      showSDoc dflags $+        vcat [ text "Unexpected backpack instantiation in dependency graph while constructing Makefile:"+             , nest 2 $ ppr node ]++processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode (ExtendedModSummary node _)))   = do  { let extra_suffixes = depSuffixes dflags               include_pkg_deps = depIncludePkgDeps dflags               src_file  = msHsFilePath node@@ -279,7 +290,7 @@             fail ->                 let dflags = hsc_dflags hsc_env                 in throwOneError $ mkPlainErrMsg dflags srcloc $-                        cannotFindModule dflags imp fail+                        cannotFindModule hsc_env imp fail         }  -----------------------------@@ -369,10 +380,12 @@   | otherwise   = putMsg dflags (hang (text "Module cycles found:") 2 pp_cycles)   where+    topoSort = filterToposortToModules $+      GHC.topSortModuleGraph True module_graph Nothing      cycles :: [[ModSummary]]     cycles =-      [ c | CyclicSCC c <- GHC.topSortModuleGraph True module_graph Nothing ]+      [ c | CyclicSCC c <- topoSort ]      pp_cycles = vcat [ (text "---------- Cycle" <+> int n <+> ptext (sLit "----------"))                         $$ pprCycle c $$ blankLine@@ -400,8 +413,8 @@            loop_breaker = head boot_only           all_others   = tail boot_only ++ others-          groups =-            GHC.topSortModuleGraph True (mkModuleGraph all_others) Nothing+          groups = filterToposortToModules $+            GHC.topSortModuleGraph True (mkModuleGraph $ extendModSummaryNoDeps <$> all_others) Nothing      pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' '))                        <+> (pp_imps empty (map snd (ms_imps summary)) $$

@@ -65,8 +65,6 @@  import GHC.Linker.ExtraObj import GHC.Linker.Dynamic-import GHC.Linker.MacOS-import GHC.Linker.Unit import GHC.Linker.Static import GHC.Linker.Types @@ -96,6 +94,7 @@ import GHC.Types.SourceError  import GHC.Unit+import GHC.Unit.Env import GHC.Unit.State import GHC.Unit.Finder import GHC.Unit.Module.ModSummary@@ -340,14 +339,18 @@        current_dir = takeDirectory basename        old_paths   = includePaths dflags2        !prevailing_dflags = hsc_dflags hsc_env0+       loadAsByteCode+         | Just (Target _ obj _) <- findTarget summary (hsc_targets hsc_env0)+         , not obj+         = True+         | otherwise = False        -- Figure out which backend we're using        (bcknd, dflags3)          -- #8042: When module was loaded with `*` prefix in ghci, but DynFlags          -- suggest to generate object code (which may happen in case -fobject-code          -- was set), force it to generate byte-code. This is NOT transitive and          -- only applies to direct targets.-         | Just (Target _ obj _) <- findTarget summary (hsc_targets hsc_env0)-         , not obj+         | loadAsByteCode          = (Interpreter, dflags2 { backend = Interpreter })          | otherwise          = (backend dflags, dflags2)@@ -363,7 +366,10 @@        -- -fforce-recomp should also work with --make        force_recomp = gopt Opt_ForceRecomp dflags        source_modified-         | force_recomp = SourceModified+         -- #8042: Usually pre-compiled code is preferred to be loaded in ghci+         -- if available. So, if the "*" prefix was used, force recompilation+         -- to make sure byte-code is loaded.+         | force_recomp || loadAsByteCode = SourceModified          | otherwise = source_modified0         always_do_basic_recompilation_check = case bcknd of@@ -479,10 +485,11 @@ -- by shortening the library names, or start putting libraries into the same -- folders, such that one runpath would be sufficient for multiple/all -- libraries.-link :: GhcLink                 -- interactive or batch-     -> DynFlags                -- dynamic flags-     -> Bool                    -- attempt linking in batch mode?-     -> HomePackageTable        -- what to link+link :: GhcLink                 -- ^ interactive or batch+     -> DynFlags                -- ^ dynamic flags+     -> UnitEnv                 -- ^ unit environment+     -> Bool                    -- ^ attempt linking in batch mode?+     -> HomePackageTable        -- ^ what to link      -> IO SuccessFlag  -- For the moment, in the batch linker, we don't bother to tell doLink@@ -492,7 +499,7 @@ -- exports main, i.e., we have good reason to believe that linking -- will succeed. -link ghcLink dflags+link ghcLink dflags unit_env   = lookupHook linkHook l dflags ghcLink dflags   where     l LinkInMemory _ _ _@@ -505,24 +512,25 @@       = return Succeeded      l LinkBinary dflags batch_attempt_linking hpt-      = link' dflags batch_attempt_linking hpt+      = link' dflags unit_env batch_attempt_linking hpt      l LinkStaticLib dflags batch_attempt_linking hpt-      = link' dflags batch_attempt_linking hpt+      = link' dflags unit_env batch_attempt_linking hpt      l LinkDynLib dflags batch_attempt_linking hpt-      = link' dflags batch_attempt_linking hpt+      = link' dflags unit_env batch_attempt_linking hpt  panicBadLink :: GhcLink -> a panicBadLink other = panic ("link: GHC not built to link this way: " ++                             show other) -link' :: DynFlags                -- dynamic flags-      -> Bool                    -- attempt linking in batch mode?-      -> HomePackageTable        -- what to link+link' :: DynFlags                -- ^ dynamic flags+      -> UnitEnv                 -- ^ unit environment+      -> Bool                    -- ^ attempt linking in batch mode?+      -> HomePackageTable        -- ^ what to link       -> IO SuccessFlag -link' dflags batch_attempt_linking hpt+link' dflags unit_env batch_attempt_linking hpt    | batch_attempt_linking    = do         let@@ -551,7 +559,7 @@             platform  = targetPlatform dflags             exe_file  = exeFileName platform staticLink (outputFile dflags) -        linking_needed <- linkingNeeded dflags staticLink linkables pkg_deps+        linking_needed <- linkingNeeded dflags unit_env staticLink linkables pkg_deps          if not (gopt Opt_ForceRecomp dflags) && not linking_needed            then do debugTraceMsg dflags 2 (text exe_file <+> text "is up to date, linking not required.")@@ -566,7 +574,7 @@                 LinkStaticLib -> linkStaticLib                 LinkDynLib    -> linkDynLibCheck                 other         -> panicBadLink other-        link dflags obj_files pkg_deps+        link dflags unit_env obj_files pkg_deps          debugTraceMsg dflags 3 (text "link: done") @@ -579,13 +587,14 @@         return Succeeded  -linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [UnitId] -> IO Bool-linkingNeeded dflags staticLink linkables pkg_deps = do+linkingNeeded :: DynFlags -> UnitEnv -> Bool -> [Linkable] -> [UnitId] -> IO Bool+linkingNeeded dflags unit_env staticLink linkables pkg_deps = do         -- if the modification time on the executable is later than the         -- modification times on all of the objects and libraries, then omit         -- linking (unless the -fforce-recomp flag was given).-  let platform = targetPlatform dflags-      exe_file = exeFileName platform staticLink (outputFile dflags)+  let platform   = ue_platform unit_env+      unit_state = ue_units unit_env+      exe_file   = exeFileName platform staticLink (outputFile dflags)   e_exe_time <- tryIO $ getModificationUTCTime exe_file   case e_exe_time of     Left _  -> return True@@ -601,10 +610,9 @@          -- next, check libraries. XXX this only checks Haskell libraries,         -- not extra_libraries or -l things from the command line.-        let unit_state = unitState dflags-        let pkg_hslibs  = [ (collectLibraryPaths (ways dflags) [c], lib)+        let pkg_hslibs  = [ (collectLibraryDirs (ways dflags) [c], lib)                           | Just c <- map (lookupUnitId unit_state) pkg_deps,-                            lib <- packageHsLibs dflags c ]+                            lib <- unitHsLibs (ghcNameVersion dflags) (ways dflags) c ]          pkg_libfiles <- mapM (uncurry (findHSLib platform (ways dflags))) pkg_hslibs         if any isNothing pkg_libfiles then return True else do@@ -613,7 +621,7 @@         let (lib_errs,lib_times) = partitionEithers e_lib_times         if not (null lib_errs) || any (t <) lib_times            then return True-           else checkLinkInfo dflags pkg_deps exe_file+           else checkLinkInfo dflags unit_env pkg_deps exe_file  findHSLib :: Platform -> Ways -> [String] -> String -> IO (Maybe FilePath) findHSLib platform ws dirs lib = do@@ -631,7 +639,7 @@ oneShot :: HscEnv -> Phase -> [(String, Maybe Phase)] -> IO () oneShot hsc_env stop_phase srcs = do   o_files <- mapM (compileFile hsc_env stop_phase) srcs-  doLink (hsc_dflags hsc_env) stop_phase o_files+  doLink hsc_env stop_phase o_files  compileFile :: HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath compileFile hsc_env stop_phase (src, mb_phase) = do@@ -665,17 +673,20 @@    return out_file  -doLink :: DynFlags -> Phase -> [FilePath] -> IO ()-doLink dflags stop_phase o_files+doLink :: HscEnv -> Phase -> [FilePath] -> IO ()+doLink hsc_env stop_phase o_files   | not (isStopLn stop_phase)   = return ()           -- We stopped before the linking phase    | otherwise-  = case ghcLink dflags of+  = let+        dflags   = hsc_dflags   hsc_env+        unit_env = hsc_unit_env hsc_env+    in case ghcLink dflags of         NoLink        -> return ()-        LinkBinary    -> linkBinary         dflags o_files []-        LinkStaticLib -> linkStaticLib      dflags o_files []-        LinkDynLib    -> linkDynLibCheck    dflags o_files []+        LinkBinary    -> linkBinary         dflags unit_env o_files []+        LinkStaticLib -> linkStaticLib      dflags unit_env o_files []+        LinkDynLib    -> linkDynLibCheck    dflags unit_env o_files []         other         -> panicBadLink other  @@ -804,7 +815,18 @@                                       $ setDynamicNow                                       $ dflags                        hsc_env' <- newHscEnv dflags'-                       _ <- runPipeline' start_phase hsc_env' env input_fn'+                       (dbs,unit_state,home_unit) <- initUnits dflags' Nothing+                       let unit_env = UnitEnv+                             { ue_platform  = targetPlatform dflags'+                             , ue_namever   = ghcNameVersion dflags'+                             , ue_home_unit = home_unit+                             , ue_units     = unit_state+                             }+                       let hsc_env'' = hsc_env'+                            { hsc_unit_env = unit_env+                            , hsc_unit_dbs = Just dbs+                            }+                       _ <- runPipeline' start_phase hsc_env'' env input_fn'                                          maybe_loc foreign_os                        return ()          return r@@ -874,7 +896,7 @@            case phase of                HscOut {} -> do                    let noDynToo = do-                        (next_phase, output_fn) <- runHookedPhase phase input_fn dflags+                        (next_phase, output_fn) <- runHookedPhase phase input_fn                         pipeLoop next_phase output_fn                    let dynToo = do                           -- if Opt_BuildDynamicToo is set and if the platform@@ -883,7 +905,7 @@                           -- the non-dynamic ones.                           let dflags' = setDynamicNow dflags -- set "dynamicNow"                           setDynFlags dflags'-                          (next_phase, output_fn) <- runHookedPhase phase input_fn dflags'+                          (next_phase, output_fn) <- runHookedPhase phase input_fn                           _ <- pipeLoop next_phase output_fn                           -- TODO: we probably shouldn't ignore the result of                           -- the dynamic compilation@@ -902,13 +924,13 @@                         -- we set DynamicNow but we unset Opt_BuildDynamicToo so                         -- it's weird.                _ -> do-                  (next_phase, output_fn) <- runHookedPhase phase input_fn dflags+                  (next_phase, output_fn) <- runHookedPhase phase input_fn                   pipeLoop next_phase output_fn -runHookedPhase :: PhasePlus -> FilePath -> DynFlags-               -> CompPipeline (PhasePlus, FilePath)-runHookedPhase pp input dflags =-  lookupHook runPhaseHook runPhase dflags pp input dflags+runHookedPhase :: PhasePlus -> FilePath -> CompPipeline (PhasePlus, FilePath)+runHookedPhase pp input = do+  dflags <- hsc_dflags <$> getPipeSession+  lookupHook runPhaseHook runPhase dflags pp input  -- ----------------------------------------------------------------------------- -- In each phase, we need to know into what filename to generate the@@ -1052,7 +1074,6 @@ -- runPhase :: PhasePlus   -- ^ Run this phase          -> FilePath    -- ^ name of the input file-         -> DynFlags    -- ^ for convenience, we pass the current dflags in          -> CompPipeline (PhasePlus,           -- next phase to run                           FilePath)            -- output filename @@ -1064,23 +1085,8 @@ ------------------------------------------------------------------------------- -- Unlit phase -runPhase (RealPhase (Unlit sf)) input_fn dflags-  = do-       output_fn <- phaseOutputFilename (Cpp sf)--       let flags = [ -- The -h option passes the file name for unlit to-                     -- put in a #line directive-                     GHC.SysTools.Option     "-h"-                     -- See Note [Don't normalise input filenames].-                   , GHC.SysTools.Option $ escape input_fn-                   , GHC.SysTools.FileOption "" input_fn-                   , GHC.SysTools.FileOption "" output_fn-                   ]--       liftIO $ GHC.SysTools.runUnlit dflags flags--       return (RealPhase (Cpp sf), output_fn)-  where+runPhase (RealPhase (Unlit sf)) input_fn = do+    let        -- escape the characters \, ", and ', but don't try to escape        -- Unicode or anything else (so we don't use Util.charToC        -- here).  If we get this wrong, then in@@ -1094,12 +1100,29 @@        escape (c:cs)    = c : escape cs        escape []        = [] +    output_fn <- phaseOutputFilename (Cpp sf)++    let flags = [ -- The -h option passes the file name for unlit to+                  -- put in a #line directive+                  GHC.SysTools.Option     "-h"+                  -- See Note [Don't normalise input filenames].+                , GHC.SysTools.Option $ escape input_fn+                , GHC.SysTools.FileOption "" input_fn+                , GHC.SysTools.FileOption "" output_fn+                ]++    dflags <- hsc_dflags <$> getPipeSession+    liftIO $ GHC.SysTools.runUnlit dflags flags++    return (RealPhase (Cpp sf), output_fn)+ ------------------------------------------------------------------------------- -- Cpp phase : (a) gets OPTIONS out of file --             (b) runs cpp if necessary -runPhase (RealPhase (Cpp sf)) input_fn dflags0+runPhase (RealPhase (Cpp sf)) input_fn   = do+       dflags0 <- getDynFlags        src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn        (dflags1, unhandled_flags, warns)            <- liftIO $ parseDynamicFilePragma dflags0 src_opts@@ -1116,7 +1139,9 @@            return (RealPhase (HsPp sf), input_fn)         else do             output_fn <- phaseOutputFilename (HsPp sf)-            liftIO $ doCpp dflags1 True{-raw-}+            hsc_env <- getPipeSession+            liftIO $ doCpp (hsc_dflags hsc_env) (hsc_unit_env hsc_env)+                           True{-raw-}                            input_fn output_fn             -- re-read the pragmas now that we've preprocessed the file             -- See #2464,#3457@@ -1135,8 +1160,9 @@ ------------------------------------------------------------------------------- -- HsPp phase -runPhase (RealPhase (HsPp sf)) input_fn dflags-  = if not (gopt Opt_Pp dflags) then+runPhase (RealPhase (HsPp sf)) input_fn = do+    dflags <- getDynFlags+    if not (gopt Opt_Pp dflags) then       -- no need to preprocess, just pass input file along       -- to the next phase of the pipeline.        return (RealPhase (Hsc sf), input_fn)@@ -1166,8 +1192,9 @@  -- Compilation of a single module, in "legacy" mode (_not_ under -- the direction of the compilation manager).-runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0+runPhase (RealPhase (Hsc src_flavour)) input_fn  = do   -- normal Hsc mode, not mkdependHS+        dflags0 <- getDynFlags          PipeEnv{ stop_phase=stop,                  src_basename=basename,@@ -1270,7 +1297,8 @@         return (HscOut src_flavour mod_name result,                 panic "HscOut doesn't have an input filename") -runPhase (HscOut src_flavour mod_name result) _ dflags = do+runPhase (HscOut src_flavour mod_name result) _ = do+        dflags <- getDynFlags         location <- getLocation src_flavour mod_name         setModLocation location @@ -1335,14 +1363,18 @@ ----------------------------------------------------------------------------- -- Cmm phase -runPhase (RealPhase CmmCpp) input_fn dflags-  = do output_fn <- phaseOutputFilename Cmm-       liftIO $ doCpp dflags False{-not raw-}+runPhase (RealPhase CmmCpp) input_fn = do+       hsc_env <- getPipeSession+       output_fn <- phaseOutputFilename Cmm+       liftIO $ doCpp (hsc_dflags hsc_env) (hsc_unit_env hsc_env)+                      False{-not raw-}                       input_fn output_fn        return (RealPhase Cmm, output_fn) -runPhase (RealPhase Cmm) input_fn dflags-  = do let next_phase = hscPostBackendPhase HsSrcFile (backend dflags)+runPhase (RealPhase Cmm) input_fn = do+       hsc_env <- getPipeSession+       let dflags = hsc_dflags hsc_env+       let next_phase = hscPostBackendPhase HsSrcFile (backend dflags)        output_fn <- phaseOutputFilename next_phase        PipeState{hsc_env} <- getPipeState        liftIO $ hscCompileCmmFile hsc_env input_fn output_fn@@ -1351,12 +1383,15 @@ ----------------------------------------------------------------------------- -- Cc phase -runPhase (RealPhase cc_phase) input_fn dflags+runPhase (RealPhase cc_phase) input_fn    | any (cc_phase `eqPhase`) [Cc, Ccxx, HCc, Cobjc, Cobjcxx]    = do-        let platform = targetPlatform dflags-            hcc = cc_phase `eqPhase` HCc-            home_unit = mkHomeUnitFromFlags dflags+        hsc_env <- getPipeSession+        let dflags    = hsc_dflags hsc_env+        let unit_env  = hsc_unit_env hsc_env+        let home_unit = hsc_home_unit hsc_env+        let platform  = ue_platform unit_env+        let hcc       = cc_phase `eqPhase` HCc          let cmdline_include_paths = includePaths dflags @@ -1366,11 +1401,8 @@         -- add package include paths even if we're just compiling .c         -- files; this is the Value Add(TM) that using ghc instead of         -- gcc gives you :)-        pkg_include_dirs <- liftIO $ getUnitIncludePath-                                       (initSDocContext dflags defaultUserStyle)-                                       (unitState dflags)-                                       home_unit-                                       pkgs+        ps <- liftIO $ mayThrowUnitErr (preloadUnitsInfo' unit_env pkgs)+        let pkg_include_dirs     = collectIncludeDirs ps         let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []               (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)         let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []@@ -1395,26 +1427,17 @@         -- cc-options are not passed when compiling .hc files.  Our         -- hc code doesn't not #include any header files anyway, so these         -- options aren't necessary.-        pkg_extra_cc_opts <- liftIO $-          if hcc-             then return []-             else getUnitExtraCcOpts-                     (initSDocContext dflags defaultUserStyle)-                     (unitState dflags)-                     home_unit-                     pkgs+        let pkg_extra_cc_opts+                | hcc       = []+                | otherwise = collectExtraCcOpts ps -        framework_paths <--            if platformUsesFrameworks platform-            then do pkgFrameworkPaths <- liftIO $ getUnitFrameworkPath-                                                   (initSDocContext dflags defaultUserStyle)-                                                   (unitState dflags)-                                                   home_unit-                                                   pkgs-                    let cmdlineFrameworkPaths = frameworkPaths dflags-                    return $ map ("-F"++)-                                 (cmdlineFrameworkPaths ++ pkgFrameworkPaths)-            else return []+        let framework_paths+                | platformUsesFrameworks platform+                = let pkgFrameworkPaths     = collectFrameworksDirs ps+                      cmdlineFrameworkPaths = frameworkPaths dflags+                  in map ("-F"++) (cmdlineFrameworkPaths ++ pkgFrameworkPaths)+                | otherwise+                = []          let cc_opt | optLevel dflags >= 2 = [ "-O2" ]                    | optLevel dflags >= 1 = [ "-O" ]@@ -1441,7 +1464,7 @@                 -- very weakly typed, being derived from C--.                 ["-fno-strict-aliasing"] -        ghcVersionH <- liftIO $ getGhcVersionPathName dflags+        ghcVersionH <- liftIO $ getGhcVersionPathName dflags unit_env          liftIO $ GHC.SysTools.runCc (phaseForeignLanguage cc_phase) dflags (                         [ GHC.SysTools.FileOption "" input_fn@@ -1496,14 +1519,20 @@ -- As, SpitAs phase : Assembler  -- This is for calling the assembler on a regular assembly file-runPhase (RealPhase (As with_cpp)) input_fn dflags+runPhase (RealPhase (As with_cpp)) input_fn   = do+        hsc_env <- getPipeSession+        let dflags     = hsc_dflags   hsc_env+        let unit_env   = hsc_unit_env hsc_env+        let platform   = ue_platform unit_env+         -- LLVM from version 3.0 onwards doesn't support the OS X system         -- assembler, so we use clang as the assembler instead. (#5636)-        let as_prog | backend dflags == LLVM &&-                      platformOS (targetPlatform dflags) == OSDarwin+        let as_prog | backend dflags == LLVM+                    , platformOS platform == OSDarwin                     = GHC.SysTools.runClang-                    | otherwise = GHC.SysTools.runAs+                    | otherwise+                    = GHC.SysTools.runAs          let cmdline_include_paths = includePaths dflags         let pic_c_flags = picCCOpts dflags@@ -1565,20 +1594,9 @@  ----------------------------------------------------------------------------- -- LlvmOpt phase-runPhase (RealPhase LlvmOpt) input_fn dflags-  = do-    output_fn <- phaseOutputFilename LlvmLlc--    liftIO $ GHC.SysTools.runLlvmOpt dflags-               (   optFlag-                ++ defaultOptions ++-                [ GHC.SysTools.FileOption "" input_fn-                , GHC.SysTools.Option "-o"-                , GHC.SysTools.FileOption "" output_fn]-                )--    return (RealPhase LlvmLlc, output_fn)-  where+runPhase (RealPhase LlvmOpt) input_fn = do+    hsc_env <- getPipeSession+    let dflags = hsc_dflags hsc_env         -- we always (unless -optlo specified) run Opt since we rely on it to         -- fix up some pretty big deficiencies in the code we generate         optIdx = max 0 $ min 2 $ optLevel dflags  -- ensure we're in [0,2]@@ -1587,6 +1605,8 @@                     Nothing -> panic ("runPhase LlvmOpt: llvm-passes file "                                       ++ "is missing passes for level "                                       ++ show optIdx)+        defaultOptions = map GHC.SysTools.Option . concat . fmap words . fst+                         $ unzip (llvmOptions dflags)          -- don't specify anything if user has specified commands. We do this         -- for opt but not llc since opt is very specifically for optimisation@@ -1596,31 +1616,23 @@                   then map GHC.SysTools.Option $ words llvmOpts                   else [] -        defaultOptions = map GHC.SysTools.Option . concat . fmap words . fst-                       $ unzip (llvmOptions dflags)+    output_fn <- phaseOutputFilename LlvmLlc --------------------------------------------------------------------------------- LlvmLlc phase+    liftIO $ GHC.SysTools.runLlvmOpt dflags+               (   optFlag+                ++ defaultOptions +++                [ GHC.SysTools.FileOption "" input_fn+                , GHC.SysTools.Option "-o"+                , GHC.SysTools.FileOption "" output_fn]+                ) -runPhase (RealPhase LlvmLlc) input_fn dflags-  = do-    next_phase <- if -- hidden debugging flag '-dno-llvm-mangler' to skip mangling-                     | gopt Opt_NoLlvmMangler dflags -> return (As False)-                     | otherwise -> return LlvmMangle+    return (RealPhase LlvmLlc, output_fn) -    output_fn <- phaseOutputFilename next_phase -    liftIO $ GHC.SysTools.runLlvmLlc dflags-                (  optFlag-                ++ defaultOptions-                ++ [ GHC.SysTools.FileOption "" input_fn-                   , GHC.SysTools.Option "-o"-                   , GHC.SysTools.FileOption "" output_fn-                   ]-                )+-----------------------------------------------------------------------------+-- LlvmLlc phase -    return (RealPhase next_phase, output_fn)-  where+runPhase (RealPhase LlvmLlc) input_fn = do     -- Note [Clamping of llc optimizations]     --     -- See #13724@@ -1660,45 +1672,64 @@     --     -- Observed at least with -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa     ---    llvmOpts = case optLevel dflags of-      0 -> "-O1" -- required to get the non-naive reg allocator. Passing -regalloc=greedy is not sufficient.-      1 -> "-O1"-      _ -> "-O2"+    dflags <- hsc_dflags <$> getPipeSession+    let+        llvmOpts = case optLevel dflags of+          0 -> "-O1" -- required to get the non-naive reg allocator. Passing -regalloc=greedy is not sufficient.+          1 -> "-O1"+          _ -> "-O2" -    optFlag = if null (getOpts dflags opt_lc)-              then map GHC.SysTools.Option $ words llvmOpts-              else []+        defaultOptions = map GHC.SysTools.Option . concatMap words . snd+                         $ unzip (llvmOptions dflags)+        optFlag = if null (getOpts dflags opt_lc)+                  then map GHC.SysTools.Option $ words llvmOpts+                  else [] -    defaultOptions = map GHC.SysTools.Option . concatMap words . snd-                   $ unzip (llvmOptions dflags)+    next_phase <- if -- hidden debugging flag '-dno-llvm-mangler' to skip mangling+                     | gopt Opt_NoLlvmMangler dflags -> return (As False)+                     | otherwise -> return LlvmMangle +    output_fn <- phaseOutputFilename next_phase +    liftIO $ GHC.SysTools.runLlvmLlc dflags+                (  optFlag+                ++ defaultOptions+                ++ [ GHC.SysTools.FileOption "" input_fn+                   , GHC.SysTools.Option "-o"+                   , GHC.SysTools.FileOption "" output_fn+                   ]+                )++    return (RealPhase next_phase, output_fn)+++ ----------------------------------------------------------------------------- -- LlvmMangle phase -runPhase (RealPhase LlvmMangle) input_fn dflags-  = do+runPhase (RealPhase LlvmMangle) input_fn = do       let next_phase = As False       output_fn <- phaseOutputFilename next_phase+      dflags <- hsc_dflags <$> getPipeSession       liftIO $ llvmFixupAsm dflags input_fn output_fn       return (RealPhase next_phase, output_fn)  ----------------------------------------------------------------------------- -- merge in stub objects -runPhase (RealPhase MergeForeign) input_fn dflags- = do+runPhase (RealPhase MergeForeign) input_fn = do      PipeState{foreign_os} <- getPipeState      output_fn <- phaseOutputFilename StopLn      liftIO $ createDirectoryIfMissing True (takeDirectory output_fn)      if null foreign_os        then panic "runPhase(MergeForeign): no foreign objects"        else do+         dflags <- hsc_dflags <$> getPipeSession          liftIO $ joinObjectFiles dflags (input_fn : foreign_os) output_fn          return (RealPhase StopLn, output_fn)  -- warning suppression-runPhase (RealPhase other) _input_fn _dflags =+runPhase (RealPhase other) _input_fn =    panic ("runPhase: don't know how to run phase " ++ show other)  maybeMergeForeign :: CompPipeline Phase@@ -1769,30 +1800,29 @@           return []  -linkDynLibCheck :: DynFlags -> [String] -> [UnitId] -> IO ()-linkDynLibCheck dflags o_files dep_units = do+linkDynLibCheck :: DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO ()+linkDynLibCheck dflags unit_env o_files dep_units = do   when (haveRtsOptsFlags dflags) $     putLogMsg dflags NoReason SevInfo noSrcSpan       $ withPprStyle defaultUserStyle       (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$       text "    Call hs_init_ghc() from your main() function to set these options.")-  linkDynLib dflags o_files dep_units+  linkDynLib dflags unit_env o_files dep_units   -- ----------------------------------------------------------------------------- -- Running CPP -doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO ()-doCpp dflags raw input_fn output_fn = do+-- | Run CPP+--+-- UnitState is needed to compute MIN_VERSION macros+doCpp :: DynFlags -> UnitEnv -> Bool -> FilePath -> FilePath -> IO ()+doCpp dflags unit_env raw input_fn output_fn = do     let hscpp_opts = picPOpts dflags     let cmdline_include_paths = includePaths dflags-    let home_unit = mkHomeUnitFromFlags dflags--    pkg_include_dirs <- getUnitIncludePath-                           (initSDocContext dflags defaultUserStyle)-                           (unitState dflags)-                           home_unit-                           []+    let unit_state = ue_units unit_env+    pkg_include_dirs <- mayThrowUnitErr+                        (collectIncludeDirs <$> preloadUnitsInfo unit_env)     let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []           (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)     let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []@@ -1837,13 +1867,12 @@      let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]     -- Default CPP defines in Haskell source-    ghcVersionH <- getGhcVersionPathName dflags+    ghcVersionH <- getGhcVersionPathName dflags unit_env     let hsSourceCppOpts = [ "-include", ghcVersionH ]      -- MIN_VERSION macros-    let state = unitState dflags-        uids = explicitUnits state-        pkgs = catMaybes (map (lookupUnit state) uids)+    let uids = explicitUnits unit_state+        pkgs = catMaybes (map (lookupUnit unit_state) uids)     mb_macro_include <-         if not (null pkgs) && gopt Opt_VersionMacros dflags             then do macro_stub <- newTempName dflags TFL_CurrentModule "h"@@ -2053,16 +2082,13 @@   GHC.SysTools.touch dflags "Touching object file" path  -- | Find out path to @ghcversion.h@ file-getGhcVersionPathName :: DynFlags -> IO FilePath-getGhcVersionPathName dflags = do+getGhcVersionPathName :: DynFlags -> UnitEnv -> IO FilePath+getGhcVersionPathName dflags unit_env = do   candidates <- case ghcVersionFile dflags of     Just path -> return [path]-    Nothing -> (map (</> "ghcversion.h")) <$>-               (getUnitIncludePath-                  (initSDocContext dflags defaultUserStyle)-                  (unitState dflags)-                  (mkHomeUnitFromFlags dflags)-                  [rtsUnitId])+    Nothing -> do+        ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env [rtsUnitId])+        return ((</> "ghcversion.h") <$> collectIncludeDirs ps)    found <- filterM doesFileExist candidates   case found of

@@ -136,11 +136,7 @@                             })    = do { let dflags = hsc_dflags hsc_env-             home_unit = hsc_home_unit hsc_env-             print_unqual = mkPrintUnqualified-                              (unitState dflags)-                              home_unit-                              rdr_env+             print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env         ; withTiming dflags                      (text "Desugar"<+>brackets (ppr mod))                      (const ()) $

@@ -18,7 +18,7 @@  module GHC.HsToCore.Binds    ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec-   , dsHsWrapper, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds, dsMkUserRule+   , dsHsWrapper, dsEvTerm, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds, dsMkUserRule    ) where 

@@ -511,7 +511,7 @@  addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc) addTickHsExpr e@(HsVar _ (L _ id))  = do freeVar id; return e-addTickHsExpr e@(HsUnboundVar id _) = do freeVar id; return e+addTickHsExpr e@(HsUnboundVar {})   = return e addTickHsExpr e@(HsRecFld _ (Ambiguous id _))   = do freeVar id; return e addTickHsExpr e@(HsRecFld _ (Unambiguous id _)) = do freeVar id; return e addTickHsExpr e@(HsConLikeOut _ con)

@@ -220,7 +220,7 @@  h98ConArgDocs :: HsConDeclH98Details GhcRn -> Map Int HsDocString h98ConArgDocs con_args = case con_args of-  PrefixCon args     -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args+  PrefixCon _ args   -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args   InfixCon arg1 arg2 -> con_arg_docs 0 [ unLoc (hsScaledThing arg1)                                        , unLoc (hsScaledThing arg2) ]   RecCon _           -> M.empty

@@ -268,7 +268,8 @@ dsExpr (HsVar    _ (L _ id))           = dsHsVar id dsExpr (HsRecFld _ (Unambiguous id _)) = dsHsVar id dsExpr (HsRecFld _ (Ambiguous   id _)) = dsHsVar id-dsExpr (HsUnboundVar id _)             = dsHsVar id+dsExpr (HsUnboundVar (HER ref _ _) _)  = dsEvTerm =<< readMutVar ref+        -- See Note [Holes] in GHC.Tc.Types.Constraint  dsExpr (HsPar _ e)            = dsLExpr e dsExpr (ExprWithTySig _ e _)  = dsLExpr e@@ -822,7 +823,7 @@                  req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys                   pat = noLoc $ ConPat { pat_con = noLoc con-                                      , pat_args = PrefixCon $ map nlVarPat arg_ids+                                      , pat_args = PrefixCon [] $ map nlVarPat arg_ids                                       , pat_con_ext = ConPatTc                                         { cpt_tvs = ex_tvs                                         , cpt_dicts = eqs_vars ++ theta_vars

@@ -350,7 +350,8 @@   -- Data types with a single constructor, which has a single arg   -- This includes types like Ptr and ForeignPtr   | Just (tycon, tycon_arg_tys) <- maybe_tc_app-  , Just data_con <- isDataProductTyCon_maybe tycon  -- One constructor, no existentials+  , Just data_con <- tyConSingleAlgDataCon_maybe tycon  -- One constructor+  , null (dataConExTyCoVars data_con)                   -- no existentials   , [Scaled _ unwrapped_res_ty] <- dataConInstOrigArgTys data_con tycon_arg_tys  -- One argument   = do { (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty        ; let marshal_con e  = Var (dataConWrapId data_con)

@@ -573,9 +573,9 @@                            -> HsConPatDetails GhcTc -> HsConPatDetails GhcTc -- See Note [Bang patterns and newtypes] -- We are transforming   !(N p)   into   (N !p)-push_bang_into_newtype_arg l _ty (PrefixCon (arg:args))+push_bang_into_newtype_arg l _ty (PrefixCon ts (arg:args))   = ASSERT( null args)-    PrefixCon [L l (BangPat noExtField arg)]+    PrefixCon ts [L l (BangPat noExtField arg)] push_bang_into_newtype_arg l _ty (RecCon rf)   | HsRecFields { rec_flds = L lf fld : flds } <- rf   , HsRecField { hsRecFieldArg = arg } <- fld@@ -584,7 +584,7 @@                                            = L l (BangPat noExtField arg) })] }) push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {})   | HsRecFields { rec_flds = [] } <- rf-  = PrefixCon [L l (BangPat noExtField (noLoc (WildPat ty)))]+  = PrefixCon [] [L l (BangPat noExtField (noLoc (WildPat ty)))] push_bang_into_newtype_arg _ _ cd   = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd) 

@@ -248,7 +248,7 @@ selectConMatchVars :: [Scaled Type] -> ConArgPats -> DsM [Id] selectConMatchVars arg_tys con = case con of                                    (RecCon {}) -> newSysLocalsDsNoLP arg_tys-                                   (PrefixCon ps) -> selectMatchVars (zipMults arg_tys ps)+                                   (PrefixCon _ ps) -> selectMatchVars (zipMults arg_tys ps)                                    (InfixCon p1 p2) -> selectMatchVars (zipMults arg_tys [p1, p2])   where     zipMults = zipWithEqual "selectConMatchVar" (\a b -> (scaledMult a, unLoc b))@@ -258,7 +258,7 @@                           -- are probably never looked at anyway            -> ConArgPats            -> [Pat GhcTc]-conArgPats _arg_tys (PrefixCon ps)   = map unLoc ps+conArgPats _arg_tys (PrefixCon _ ps) = map unLoc ps conArgPats _arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2] conArgPats  arg_tys (RecCon (HsRecFields { rec_flds = rpats }))   | null rpats = map WildPat (map scaledThing arg_tys)

@@ -86,11 +86,10 @@ import GHC.Data.Bag import GHC.Data.FastString +import GHC.Unit.Env import GHC.Unit.External import GHC.Unit.Module import GHC.Unit.Module.ModGuts-import GHC.Unit.Home-import GHC.Unit.State  import GHC.Types.Name.Reader import GHC.Types.Basic ( Origin )@@ -229,9 +228,7 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env   = do { cc_st_var   <- liftIO $ newIORef newCostCentreState        ; eps <- liftIO $ hscEPS hsc_env-       ; let dflags   = hsc_dflags hsc_env-             home_unit = hsc_home_unit hsc_env-             unit_state = unitState dflags+       ; let unit_env = hsc_unit_env hsc_env              this_mod = tcg_mod tcg_env              type_env = tcg_type_env tcg_env              rdr_env  = tcg_rdr_env tcg_env@@ -239,7 +236,7 @@              complete_matches = hptCompleteSigs hsc_env         -- from the home package                                 ++ tcg_complete_matches tcg_env -- from the current module                                 ++ eps_complete_matches eps     -- from imports-       ; return $ mkDsEnvs unit_state home_unit this_mod rdr_env type_env fam_inst_env+       ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env                            msg_var cc_st_var complete_matches        } @@ -262,9 +259,7 @@   = do { cc_st_var   <- newIORef newCostCentreState        ; msg_var <- newIORef emptyMessages        ; eps <- liftIO $ hscEPS hsc_env-       ; let dflags   = hsc_dflags hsc_env-             home_unit = hsc_home_unit hsc_env-             unit_state = unitState dflags+       ; let unit_env = hsc_unit_env hsc_env              type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts)              rdr_env  = mg_rdr_env guts              fam_inst_env = mg_fam_inst_env guts@@ -277,7 +272,7 @@              bindsToIds (Rec    binds) = map fst binds              ids = concatMap bindsToIds (mg_binds guts) -             envs  = mkDsEnvs unit_state home_unit this_mod rdr_env type_env+             envs  = mkDsEnvs unit_env this_mod rdr_env type_env                               fam_inst_env msg_var cc_st_var                               complete_matches        ; runDs hsc_env envs thing_inside@@ -298,18 +293,25 @@        ; hsc_env    <- getTopEnv         ; let DsGblEnv { ds_mod = mod-                      , ds_fam_inst_env = fam_inst_env } = gbl+                      , ds_fam_inst_env = fam_inst_env+                      , ds_gbl_rdr_env  = rdr_env }      = gbl+       -- This is *the* use of ds_gbl_rdr_env:+       -- Make sure the solver (used by the pattern-match overlap checker) has+       -- access to the GlobalRdrEnv and FamInstEnv for the module, so that it+       -- knows how to reduce type families, and which newtypes it can unwrap. +              DsLclEnv { dsl_loc = loc }                  = lcl         ; liftIO $ initTc hsc_env HsSrcFile False mod loc $-         updGblEnv (\tc_gbl -> tc_gbl { tcg_fam_inst_env = fam_inst_env }) $+         updGblEnv (\tc_gbl -> tc_gbl { tcg_fam_inst_env = fam_inst_env+                                      , tcg_rdr_env      = rdr_env }) $          thing_inside } -mkDsEnvs :: UnitState -> HomeUnit -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv+mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv          -> IORef Messages -> IORef CostCentreState -> CompleteMatches          -> (DsGblEnv, DsLclEnv)-mkDsEnvs unit_state home_unit mod rdr_env type_env fam_inst_env msg_var cc_st_var+mkDsEnvs unit_env mod rdr_env type_env fam_inst_env msg_var cc_st_var          complete_matches   = let if_genv = IfGblEnv { if_doc       = text "mkDsEnvs",                              if_rec_types = Just (mod, return type_env) }@@ -318,8 +320,9 @@         real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1)         gbl_env = DsGblEnv { ds_mod     = mod                            , ds_fam_inst_env = fam_inst_env+                           , ds_gbl_rdr_env  = rdr_env                            , ds_if_env  = (if_genv, if_lenv)-                           , ds_unqual  = mkPrintUnqualified unit_state home_unit rdr_env+                           , ds_unqual  = mkPrintUnqualified unit_env rdr_env                            , ds_msgs    = msg_var                            , ds_complete_matches = complete_matches                            , ds_cc_st   = cc_st_var

@@ -255,7 +255,7 @@ desugarConPatOut :: Id -> ConLike -> [Type] -> [TyVar]                  -> [EvVar] -> HsConPatDetails GhcTc -> DsM [PmGrd] desugarConPatOut x con univ_tys ex_tvs dicts = \case-    PrefixCon ps                 -> go_field_pats (zip [0..] ps)+    PrefixCon _ ps               -> go_field_pats (zip [0..] ps)     InfixCon  p1 p2              -> go_field_pats (zip [0..] [p1,p2])     RecCon    (HsRecFields fs _) -> go_field_pats (rec_field_ps fs)   where

@@ -58,7 +58,7 @@ import GHC.Types.Var.Set import GHC.Core import GHC.Core.FVs       (exprFreeVars)-import GHC.Core.Map+import GHC.Core.Map.Expr import GHC.Core.SimpleOpt (simpleOptExpr, exprIsConApp_maybe) import GHC.Core.Utils     (exprType) import GHC.Core.Make      (mkListExpr, mkCharExpr)

@@ -54,7 +54,7 @@ import GHC.Core.TyCon import GHC.Types.Literal import GHC.Core-import GHC.Core.Map+import GHC.Core.Map.Expr import GHC.Core.Utils (exprType) import GHC.Builtin.Names import GHC.Builtin.Types

@@ -283,7 +283,7 @@                         , hs_docs    = docs })  = do { let { bndrs  = hsScopedTvBinders valds                        ++ hsGroupBinders group-                       ++ hsPatSynSelectors valds+                       ++ map extFieldOcc (hsPatSynSelectors valds)             ; instds = tyclds >>= group_instds } ;         ss <- mkGenSyms bndrs ; @@ -1884,11 +1884,11 @@     -- their pattern-only bound right hand sides have different names,     -- we want to treat them the same in TH. This is the reason why we     -- need an adjusted mkGenArgSyms in the `RecCon` case below.-    mkGenArgSyms (PrefixCon args)     = mkGenSyms (map unLoc args)+    mkGenArgSyms (PrefixCon _ args)   = mkGenSyms (map unLoc args)     mkGenArgSyms (InfixCon arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2]     mkGenArgSyms (RecCon fields)       = do { let pats = map (unLoc . recordPatSynPatVar) fields-                 sels = map (unLoc . recordPatSynSelectorId) fields+                 sels = map (extFieldOcc . recordPatSynField) fields            ; ss <- mkGenSyms sels            ; return $ replaceNames (zip sels pats) ss } @@ -1910,7 +1910,7 @@   = rep2 patSynDName [syn, args, dir, pat]  repPatSynArgs :: HsPatSynDetails GhcRn -> MetaM (Core (M TH.PatSynArgs))-repPatSynArgs (PrefixCon args)+repPatSynArgs (PrefixCon _ args)   = do { args' <- repList nameTyConName lookupLOcc args        ; repPrefixPatSynArgs args' } repPatSynArgs (InfixCon arg1 arg2)@@ -1918,9 +1918,9 @@        ; arg2' <- lookupLOcc arg2        ; repInfixPatSynArgs arg1' arg2' } repPatSynArgs (RecCon fields)-  = do { sels' <- repList nameTyConName lookupLOcc sels+  = do { sels' <- repList nameTyConName (lookupOcc . extFieldOcc) sels        ; repRecordPatSynArgs sels' }-  where sels = map recordPatSynSelectorId fields+  where sels = map recordPatSynField fields  repPrefixPatSynArgs :: Core [TH.Name] -> MetaM (Core (M TH.PatSynArgs)) repPrefixPatSynArgs (MkC nms) = rep2 prefixPatSynName [nms]@@ -2016,7 +2016,9 @@ repP (ConPat NoExtField dc details)  = do { con_str <- lookupLOcc dc       ; case details of-         PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }+         PrefixCon tyargs ps -> do { qs <- repLPs ps+                                   ; ts <- repListM typeTyConName (repTy . unLoc . hsps_body) tyargs+                                   ; repPcon con_str ts qs }          RecCon rec   -> do { fps <- repListM fieldPatTyConName rep_fld (rec_flds rec)                             ; repPrec con_str fps }          InfixCon p1 p2 -> do { p1' <- repLP p1;@@ -2028,7 +2030,6 @@    rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld)                           ; MkC p <- repLP (hsRecFieldArg fld)                           ; rep2 fieldPatName [v,p] }- repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l                                      ; repPlit a } repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }@@ -2249,8 +2250,8 @@                              , mkIntExprInt platform alt                              , mkIntExprInt platform arity ] } -repPcon   :: Core TH.Name -> Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat))-repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]+repPcon   :: Core TH.Name -> Core [(M TH.Type)] -> Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat))+repPcon (MkC s) (MkC ts) (MkC ps) = rep2 conPName [s, ts, ps]  repPrec   :: Core TH.Name -> Core [M (TH.Name, TH.Pat)] -> MetaM (Core (M TH.Pat)) repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]@@ -2621,7 +2622,7 @@ repH98DataCon con details     = do con' <- lookupLOcc con -- See Note [Binders and occurrences]          case details of-           PrefixCon ps -> do+           PrefixCon _ ps -> do              arg_tys <- repPrefixConArgs ps              rep2 normalCName [unC con', unC arg_tys]            InfixCon st1 st2 -> do

@@ -12,6 +12,7 @@ import GHC.Types.Name.Env import GHC.Types.SrcLoc import GHC.Types.Var+import GHC.Types.Name.Reader (GlobalRdrEnv) import GHC.Hs (LForeignDecl, HsExpr, GhcTc) import GHC.Tc.Types (TcRnIf, IfGblEnv, IfLclEnv, CompleteMatches) import GHC.HsToCore.Pmc.Types (Nablas)@@ -42,6 +43,9 @@   = DsGblEnv   { ds_mod          :: Module             -- For SCC profiling   , ds_fam_inst_env :: FamInstEnv         -- Like tcg_fam_inst_env+  , ds_gbl_rdr_env  :: GlobalRdrEnv       -- needed *only* to know what newtype+                                          -- constructors are in scope during+                                          -- pattern-match satisfiability checking   , ds_unqual  :: PrintUnqualified   , ds_msgs    :: IORef Messages          -- Warning messages   , ds_if_env  :: (IfGblEnv, IfLclEnv)    -- Used for looking up global,

@@ -37,8 +37,6 @@ import GHC.Unit.Module.ModIface import GHC.Unit.Module.Deps -import GHC.Linker.Unit- import GHC.Data.Maybe  import Control.Monad (filterM)@@ -186,12 +184,12 @@     LookupFound _ pkg -> do     -- The plugin is from an external package:     -- search for the library files containing the plugin.-      let searchPaths = collectLibraryPaths (ways dflags) [pkg]+      let searchPaths = collectLibraryDirs (ways dflags) [pkg]           useDyn = WayDyn `elem` ways dflags           suffix = if useDyn then platformSOExt platform else "a"           libLocs = [ searchPath </> "lib" ++ libLoc <.> suffix                     | searchPath <- searchPaths-                    , libLoc     <- packageHsLibs dflags pkg+                    , libLoc     <- unitHsLibs (ghcNameVersion dflags) (ways dflags) pkg                     ]           -- we also try to find plugin library files by adding WayDyn way,           -- if it isn't already present (see trac #15492)@@ -202,7 +200,7 @@                 let dflags'  = dflags { targetWays_ = addWay WayDyn (targetWays_ dflags) }                     dlibLocs = [ searchPath </> platformHsSOName platform dlibLoc                                | searchPath <- searchPaths-                               , dlibLoc    <- packageHsLibs dflags' pkg+                               , dlibLoc    <- unitHsLibs (ghcNameVersion dflags') (ways dflags') pkg                                ]                 in libLocs ++ dlibLocs       files <- filterM doesFileExist paths@@ -228,7 +226,7 @@   where     dflags   = hsc_dflags hsc_env     platform = targetPlatform dflags-    pkgs     = unitState dflags+    pkgs     = hsc_units hsc_env     pNm      = moduleName $ mi_module pluginModule     pPkg     = moduleUnit $ mi_module pluginModule     deps     = map gwib_mod $

@@ -494,6 +494,13 @@                           -> v1        -- Note [Desugaring seq], points (2) and (3)                    _      -> mkWildValBinder Many ty1 +mkCoreAppDs _ (Var f `App` Type _r) arg+  | f `hasKey` noinlineIdKey   -- See Note [noinlineId magic] in GHC.Types.Id.Make+  , (fun, args) <- collectArgs arg+  , not (null args)+  = (Var f `App` Type (exprType fun) `App` fun)+    `mkCoreApps` args+ mkCoreAppDs s fun arg = mkCoreApp s fun arg  -- The rest is done in GHC.Core.Make  -- NB: No argument can be levity polymorphic@@ -737,7 +744,7 @@ is_flat_prod_pat (ConPat { pat_con  = L _ pcon                          , pat_args = ps})   | RealDataCon con <- pcon-  , isProductTyCon (dataConTyCon con)+  , Just _ <- tyConSingleDataCon_maybe (dataConTyCon con)   = all is_triv_lpat (hsConPatArgs ps) is_flat_prod_pat _ = False 

@@ -18,6 +18,8 @@ Main functions for .hie file generation -} +#include "GhclibHsVersions.h"+ module GHC.Iface.Ext.Ast ( mkHieFile, mkHieFileWithSource, getCompressedAsts, enrichHie) where  import GHC.Utils.Outputable(ppr)@@ -55,6 +57,7 @@ import GHC.Builtin.Uniques import GHC.Iface.Make             ( mkIfaceExports ) import GHC.Utils.Panic+import GHC.Utils.Misc import GHC.Data.Maybe import GHC.Data.FastString @@ -69,7 +72,7 @@ import qualified Data.Map as M import qualified Data.Set as S import Data.Data                  ( Data, Typeable )-import Data.List                  ( foldl1' )+import Data.Void                  ( Void, absurd ) import Control.Monad              ( forM_ ) import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Reader@@ -162,7 +165,7 @@ straightforward.  If you are extending the GHC AST, you will need to provide a `ToHie` instance for any new types you may have introduced in the AST. -Here are is an extract from the `ToHie` instance for (LHsExpr (GhcPass p)):+Here is an extract from the `ToHie` instance for (LHsExpr (GhcPass p)):    toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of       HsVar _ (L _ var) ->@@ -484,6 +487,18 @@   map (\(RS sc a) -> PS rsp useScope sc a) $     listScopes patScope xs +-- | 'listScopes' specialised to 'HsPatSigType'+tScopes+  :: Scope+  -> Scope+  -> [HsPatSigType (GhcPass a)]+  -> [TScoped (HsPatSigType (GhcPass a))]+tScopes scope rhsScope xs =+  map (\(RS sc a) -> TS (ResolvedScopes [scope, sc]) (unLoc a)) $+    listScopes rhsScope (map (\hsps -> L (getLoc $ hsps_body hsps) hsps) xs)+  -- We make the HsPatSigType into a Located one by using the location of the underlying LHsType.+  -- We then strip off the redundant location information afterward, and take the union of the given scope and those to the right when forming the TS.+ -- | 'listScopes' specialised to 'TVScoped' things tvScopes   :: TyVarScope@@ -567,6 +582,9 @@ class HasType a where   getTypeNode :: a -> HieM [HieAST Type] +instance ToHie Void where+  toHie v = absurd v+ instance (ToHie a) => ToHie [a] where   toHie = concatMapM toHie @@ -707,6 +725,7 @@       HieTc ->         -- Some expression forms have their type immediately available         let tyOpt = case e' of+              HsUnboundVar (HER _ ty _) _ -> Just ty               HsLit _ l -> Just (hsLitType l)               HsOverLit _ o -> Just (overLitType o) @@ -746,7 +765,6 @@           skipDesugaring :: HsExpr GhcTc -> Bool           skipDesugaring e = case e of             HsVar{}             -> False-            HsUnboundVar{}      -> False             HsConLikeOut{}      -> False             HsRecFld{}          -> False             HsOverLabel{}       -> False@@ -773,7 +791,6 @@       , Data (HsTupArg (GhcPass p))       , Data (IPBind (GhcPass p))       , ToHie (Context (Located (IdGhcP p)))-      , ToHie (Context (Located (XUnboundVar (GhcPass p))))       , ToHie (RFContext (Located (AmbiguousFieldOcc (GhcPass p))))       , ToHie (RFContext (Located (FieldOcc (GhcPass p))))       , ToHie (TScoped (LHsWcType (GhcPass (NoGhcTcPass p))))@@ -855,15 +872,15 @@           varScope = mkLScope var           patScope = mkScope $ getLoc pat           detScope = case dets of-            (PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args+            (PrefixCon _ args) -> foldr combineScopes NoScope $ map mkLScope args             (InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b)             (RecCon r) -> foldr go NoScope r           go (RecordPatSynField a b) c = combineScopes c-            $ combineScopes (mkLScope a) (mkLScope b)+            $ combineScopes (mkLScope (rdrNameFieldOcc a)) (mkLScope b)           detSpan = case detScope of             LocalScope a -> Just a             _ -> Nothing-          toBind (PrefixCon args) = PrefixCon $ map (C Use) args+          toBind (PrefixCon ts args) = ASSERT(null ts) PrefixCon ts $ map (C Use) args           toBind (InfixCon a b) = InfixCon (C Use a) (C Use b)           toBind (RecCon r) = RecCon $ map (PSC detSpan) r @@ -945,7 +962,7 @@                             , toHie $ L ospan wrap                             , toHie $ map (C (EvidenceVarBind EvPatternBind evscope rsp)                                           . L ospan) ev_vars-                          ]+                            ]             ]           HieRn ->             [ toHie $ C Use con@@ -985,9 +1002,10 @@           HieRn -> [] #endif     where-      contextify :: a ~ LPat (GhcPass p) => HsConDetails a (HsRecFields (GhcPass p) a)-                 -> HsConDetails (PScoped a) (RContext (HsRecFields (GhcPass p) (PScoped a)))-      contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args+      contextify :: a ~ LPat (GhcPass p) => HsConDetails (HsPatSigType (NoGhcTc (GhcPass p))) a (HsRecFields (GhcPass p) a)+                 -> HsConDetails (TScoped (HsPatSigType (NoGhcTc (GhcPass p)))) (PScoped a) (RContext (HsRecFields (GhcPass p) (PScoped a)))+      contextify (PrefixCon tyargs args) = PrefixCon (tScopes scope argscope tyargs) (patScopes rsp scope pscope args)+        where argscope = foldr combineScopes NoScope $ map mkLScope args       contextify (InfixCon a b) = InfixCon a' b'         where [a', b'] = patScopes rsp scope pscope [a,b]       contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r@@ -1034,8 +1052,7 @@         [ toHie $ C Use (L mspan var)              -- Patch up var location since typechecker removes it         ]-      HsUnboundVar var _ ->-        [ toHie $ C Use (L mspan var) ]+      HsUnboundVar _ _ -> []  -- there is an unbound name here, but that causes trouble       HsConLikeOut _ con ->         [ toHie $ C Use $ L mspan $ conLikeName con         ]@@ -1303,8 +1320,8 @@     , toHie $ PS Nothing sc NoScope pat     ] -instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where-  toHie (PrefixCon args) = toHie args+instance (ToHie tyarg, ToHie arg, ToHie rec) => ToHie (HsConDetails tyarg arg rec) where+  toHie (PrefixCon tyargs args) = concatM [ toHie tyargs, toHie args ]   toHie (RecCon rec) = toHie rec   toHie (InfixCon a b) = concatM [ toHie a, toHie b] @@ -1554,9 +1571,9 @@           rhsScope = combineScopes ctxScope argsScope           ctxScope = maybe NoScope mkLScope ctx           argsScope = case dets of-            PrefixCon xs -> scaled_args_scope xs-            InfixCon a b -> scaled_args_scope [a, b]-            RecCon x     -> mkLScope x+            PrefixCon _ xs -> scaled_args_scope xs+            InfixCon a b   -> scaled_args_scope [a, b]+            RecCon x       -> mkLScope x     where scaled_args_scope :: [HsScaled GhcRn (LHsType GhcRn)] -> Scope           scaled_args_scope = foldr combineScopes NoScope . map (mkLScope . hsScaledThing) @@ -1870,8 +1887,12 @@ instance ToHie (Located (TyFamInstDecl GhcRn)) where   toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d -instance ToHie (Context a)-         => ToHie (PatSynFieldContext (RecordPatSynField a)) where+instance HiePass p => ToHie (Context (FieldOcc (GhcPass p))) where+  toHie (C c (FieldOcc n (L l _))) = case hiePass @p of+    HieTc -> toHie (C c (L l n))+    HieRn -> toHie (C c (L l n))++instance HiePass p => ToHie (PatSynFieldContext (RecordPatSynField (GhcPass p))) where   toHie (PSC sp (RecordPatSynField a b)) = concatM $     [ toHie $ C (RecField RecFieldDecl sp) a     , toHie $ C Use b@@ -2003,7 +2024,7 @@       IEThingAll _ n ->         [ toHie $ IEC c n         ]-      IEThingWith _ n _ ns flds ->+      IEThingWith flds n _ ns ->         [ toHie $ IEC c n         , toHie $ map (IEC c) ns         , toHie $ map (IEC c) flds@@ -2027,7 +2048,7 @@         [ toHie $ C (IEThing c) n         ] -instance ToHie (IEContext (Located (FieldLbl Name))) where+instance ToHie (IEContext (Located FieldLabel)) where   toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of       FieldLabel _ _ n ->         [ toHie $ C (IEThing c) $ L span n

@@ -8,7 +8,7 @@  import GHC.Prelude -import GHC.Core.Map+import GHC.Core.Map.Type import GHC.Driver.Session    ( DynFlags ) import GHC.Driver.Ppr import GHC.Data.FastString   ( FastString, mkFastString )

@@ -7,6 +7,7 @@ {-# LANGUAGE CPP, BangPatterns, RecordWildCards, NondecreasingIndentation #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleContexts #-}  {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -30,12 +31,16 @@         needWiredInHomeIface, loadWiredInHomeIface,          pprModIfaceSimple,-        ifaceStats, pprModIface, showIface+        ifaceStats, pprModIface, showIface,++        cannotFindModule    ) where  #include "GhclibHsVersions.h"  import GHC.Prelude+import GHC.Platform.Ways+import GHC.Platform.Profile  import {-# SOURCE #-} GHC.IfaceToCore    ( tcIfaceDecls, tcIfaceRules, tcIfaceInst, tcIfaceFamInst@@ -87,7 +92,6 @@ import GHC.Types.Unique.FM import GHC.Types.Unique.DSet import GHC.Types.SrcLoc-import GHC.Types.FieldLabel import GHC.Types.TyThing  import GHC.Unit.External@@ -99,6 +103,7 @@ import GHC.Unit.Home import GHC.Unit.Home.ModInfo import GHC.Unit.Finder+import GHC.Unit.Env  import GHC.Data.Maybe import GHC.Data.FastString@@ -310,7 +315,7 @@        ; case res of            Found _ mod -> initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot)            -- TODO: Make sure this error message is good-           err         -> return (Failed (cannotFindModule (hsc_dflags hsc_env) mod err)) }+           err         -> return (Failed (cannotFindModule hsc_env mod err)) }  -- | Load interface directly for a fully qualified 'Module'.  (This is a fairly -- rare operation, but in particular it is used to load orphan modules@@ -839,7 +844,7 @@                -- Look for the file                hsc_env <- getTopEnv                mb_found <- liftIO (findExactModule hsc_env mod)-               let home_unit = hsc_home_unit hsc_env+               let home_unit  = hsc_home_unit hsc_env                case mb_found of                    InstalledFound loc mod -> do                        -- Found file, so read it@@ -855,20 +860,25 @@                                    return r                    err -> do                        traceIf (text "...not found")-                       dflags <- getDynFlags-                       return (Failed (cannotFindInterface dflags-                                           (moduleName mod) err))+                       hsc_env <- getTopEnv+                       let profile = Profile (targetPlatform dflags) (ways dflags)+                       return $ Failed $ cannotFindInterface+                                           (hsc_unit_env hsc_env)+                                           profile+                                           (may_show_locations (hsc_dflags hsc_env))+                                           (moduleName mod)+                                           err     where read_file file_path = do               traceIf (text "readIFace" <+> text file_path)               -- Figure out what is recorded in mi_module.  If this is               -- a fully definite interface, it'll match exactly, but               -- if it's indefinite, the inside will be uninstantiated!-              dflags <- getDynFlags+              unit_state <- hsc_units <$> getTopEnv               let wanted_mod =                     case getModuleInstantiation wanted_mod_with_insts of                         (_, Nothing) -> wanted_mod_with_insts                         (_, Just indef_mod) ->-                          instModuleToModule (unitState dflags)+                          instModuleToModule unit_state                             (uninstantiateInstantiatedModule indef_mod)               read_result <- readIface wanted_mod file_path               case read_result of@@ -946,8 +956,8 @@ ********************************************************* -} -initExternalPackageState :: HomeUnit -> ExternalPackageState-initExternalPackageState home_unit+initExternalPackageState :: UnitId -> ExternalPackageState+initExternalPackageState home_unit_id   = EPS {       eps_is_boot          = emptyUFM,       eps_PIT              = emptyPackageIfaceTable,@@ -966,9 +976,9 @@     }     where       enableBignumRules-         | isHomeUnitInstanceOf home_unit primUnitId   = EnableBignumRules False-         | isHomeUnitInstanceOf home_unit bignumUnitId = EnableBignumRules False-         | otherwise                                   = EnableBignumRules True+         | home_unit_id == primUnitId   = EnableBignumRules False+         | home_unit_id == bignumUnitId = EnableBignumRules False+         | otherwise                    = EnableBignumRules True       builtinRules' = builtinRules enableBignumRules  {-@@ -1042,7 +1052,7 @@ showIface :: HscEnv -> FilePath -> IO () showIface hsc_env filename = do    let dflags  = hsc_dflags hsc_env-       unit_state = unitState dflags+       unit_state = hsc_units hsc_env        printer = putLogMsg dflags NoReason SevOutput noSrcSpan . withPprStyle defaultDumpStyle     -- skip the hi way check; we don't want to worry about profiled vs.@@ -1059,17 +1069,21 @@                                    neverQualifyPackages    putLogMsg dflags NoReason SevDump noSrcSpan       $ withPprStyle (mkDumpStyle print_unqual)-      $ pprWithUnitState unit_state-      $ pprModIface iface+      $ pprModIface unit_state iface --- Show a ModIface but don't display details; suitable for ModIfaces stored in+-- | Show a ModIface but don't display details; suitable for ModIfaces stored in -- the EPT.-pprModIfaceSimple :: ModIface -> SDoc-pprModIfaceSimple iface = ppr (mi_module iface) $$ pprDeps (mi_deps iface) $$ nest 2 (vcat (map pprExport (mi_exports iface)))+pprModIfaceSimple :: UnitState -> ModIface -> SDoc+pprModIfaceSimple unit_state iface =+    ppr (mi_module iface)+    $$ pprDeps unit_state (mi_deps iface)+    $$ nest 2 (vcat (map pprExport (mi_exports iface))) -pprModIface :: ModIface -> SDoc--- Show a ModIface-pprModIface iface@ModIface{ mi_final_exts = exts }+-- | Show a ModIface+--+-- The UnitState is used to pretty-print units+pprModIface :: UnitState -> ModIface -> SDoc+pprModIface unit_state iface@ModIface{ mi_final_exts = exts }  = vcat [ text "interface"                 <+> ppr (mi_module iface) <+> pp_hsc_src (mi_hsc_src iface)                 <+> (if mi_orphan exts then text "[orphan module]" else Outputable.empty)@@ -1089,7 +1103,7 @@         , nest 2 (text "where")         , text "exports:"         , nest 2 (vcat (map pprExport (mi_exports iface)))-        , pprDeps (mi_deps iface)+        , pprDeps unit_state (mi_deps iface)         , vcat (map pprUsage (mi_usages iface))         , vcat (map pprIfaceAnnotation (mi_anns iface))         , pprFixities (mi_fixities iface)@@ -1119,16 +1133,17 @@ -}  pprExport :: IfaceExport -> SDoc-pprExport (Avail n)         = ppr n-pprExport (AvailTC _ [] []) = Outputable.empty-pprExport (AvailTC n ns0 fs)-  = case ns0 of-      (n':ns) | n==n' -> ppr n <> pp_export ns fs-      _               -> ppr n <> vbar <> pp_export ns0 fs+pprExport (Avail n)      = ppr n+pprExport (AvailTC _ []) = Outputable.empty+pprExport avail@(AvailTC n _) =+    ppr n <> mark <> pp_export (availSubordinateGreNames avail)   where-    pp_export []    [] = Outputable.empty-    pp_export names fs = braces (hsep (map ppr names ++ map (ppr . flLabel) fs))+    mark | availExportsDecl avail = Outputable.empty+         | otherwise              = vbar +    pp_export []    = Outputable.empty+    pp_export names = braces (hsep (map ppr names))+ pprUsage :: Usage -> SDoc pprUsage usage@UsagePackageModule{}   = pprUsageImport usage usg_mod@@ -1153,10 +1168,12 @@         safe | usg_safe usage = text "safe"              | otherwise      = text " -/ " -pprDeps :: Dependencies -> SDoc-pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs,-                dep_finsts = finsts })-  = vcat [text "module dependencies:" <+> fsep (map ppr_mod mods),+-- | Pretty-print unit dependencies+pprDeps :: UnitState -> Dependencies -> SDoc+pprDeps unit_state (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs,+                           dep_finsts = finsts })+  = pprWithUnitState unit_state $+    vcat [text "module dependencies:" <+> fsep (map ppr_mod mods),           text "package dependencies:" <+> fsep (map ppr_pkg pkgs),           text "orphans:" <+> fsep (map ppr orphs),           text "family instance modules:" <+> fsep (map ppr finsts)@@ -1242,3 +1259,268 @@            Just file -> space <> parens (text file)            Nothing   -> Outputable.empty)     <+> text "which is not loaded"+++-- -----------------------------------------------------------------------------+-- Error messages++cannotFindInterface :: UnitEnv -> Profile -> ([FilePath] -> SDoc) -> ModuleName -> InstalledFindResult -> SDoc+cannotFindInterface = cantFindInstalledErr (sLit "Failed to load interface for")+                                           (sLit "Ambiguous interface for")++cantFindInstalledErr+    :: PtrString+    -> PtrString+    -> UnitEnv+    -> Profile+    -> ([FilePath] -> SDoc)+    -> ModuleName+    -> InstalledFindResult+    -> SDoc+cantFindInstalledErr cannot_find _ unit_env profile tried_these mod_name find_result+  = ptext cannot_find <+> quotes (ppr mod_name)+    $$ more_info+  where+    home_unit  = ue_home_unit unit_env+    unit_state = ue_units unit_env+    build_tag  = waysBuildTag (profileWays profile)++    more_info+      = case find_result of+            InstalledNoPackage pkg+                -> text "no unit id matching" <+> quotes (ppr pkg) <+>+                   text "was found" $$ looks_like_srcpkgid pkg++            InstalledNotFound files mb_pkg+                | Just pkg <- mb_pkg, not (isHomeUnitId home_unit pkg)+                -> not_found_in_package pkg files++                | null files+                -> text "It is not a module in the current program, or in any known package."++                | otherwise+                -> tried_these files++            _ -> panic "cantFindInstalledErr"++    looks_like_srcpkgid :: UnitId -> SDoc+    looks_like_srcpkgid pk+     -- Unsafely coerce a unit id (i.e. an installed package component+     -- identifier) into a PackageId and see if it means anything.+     | (pkg:pkgs) <- searchPackageId unit_state (PackageId (unitIdFS pk))+     = parens (text "This unit ID looks like the source package ID;" $$+       text "the real unit ID is" <+> quotes (ftext (unitIdFS (unitId pkg))) $$+       (if null pkgs then Outputable.empty+        else text "and" <+> int (length pkgs) <+> text "other candidates"))+     -- Todo: also check if it looks like a package name!+     | otherwise = Outputable.empty++    not_found_in_package pkg files+       | build_tag /= ""+       = let+            build = if build_tag == "p" then "profiling"+                                        else "\"" ++ build_tag ++ "\""+         in+         text "Perhaps you haven't installed the " <> text build <>+         text " libraries for package " <> quotes (ppr pkg) <> char '?' $$+         tried_these files++       | otherwise+       = text "There are files missing in the " <> quotes (ppr pkg) <>+         text " package," $$+         text "try running 'ghc-pkg check'." $$+         tried_these files++may_show_locations :: DynFlags -> [FilePath] -> SDoc+may_show_locations dflags files+    | null files = Outputable.empty+    | verbosity dflags < 3 =+          text "Use -v (or `:set -v` in ghci) " <>+              text "to see a list of the files searched for."+    | otherwise =+          hang (text "Locations searched:") 2 $ vcat (map text files)++cannotFindModule :: HscEnv -> ModuleName -> FindResult -> SDoc+cannotFindModule hsc_env = cannotFindModule'+    (hsc_dflags   hsc_env)+    (hsc_unit_env hsc_env)+    (targetProfile (hsc_dflags hsc_env))+++cannotFindModule' :: DynFlags -> UnitEnv -> Profile -> ModuleName -> FindResult -> SDoc+cannotFindModule' dflags unit_env profile mod res = pprWithUnitState (ue_units unit_env) $+  cantFindErr (gopt Opt_BuildingCabalPackage dflags)+              (sLit cannotFindMsg)+              (sLit "Ambiguous module name")+              unit_env+              profile+              (may_show_locations dflags)+              mod+              res+  where+    cannotFindMsg =+      case res of+        NotFound { fr_mods_hidden = hidden_mods+                 , fr_pkgs_hidden = hidden_pkgs+                 , fr_unusables = unusables }+          | not (null hidden_mods && null hidden_pkgs && null unusables)+          -> "Could not load module"+        _ -> "Could not find module"++cantFindErr+    :: Bool -- ^ Using Cabal?+    -> PtrString+    -> PtrString+    -> UnitEnv+    -> Profile+    -> ([FilePath] -> SDoc)+    -> ModuleName+    -> FindResult+    -> SDoc+cantFindErr _ _ multiple_found _ _ _ mod_name (FoundMultiple mods)+  | Just pkgs <- unambiguousPackages+  = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 (+       sep [text "it was found in multiple packages:",+                hsep (map ppr pkgs) ]+    )+  | otherwise+  = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 (+       vcat (map pprMod mods)+    )+  where+    unambiguousPackages = foldl' unambiguousPackage (Just []) mods+    unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _)+        = Just (moduleUnit m : xs)+    unambiguousPackage _ _ = Nothing++    pprMod (m, o) = text "it is bound as" <+> ppr m <+>+                                text "by" <+> pprOrigin m o+    pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden"+    pprOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable"+    pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma (+      if e == Just True+          then [text "package" <+> ppr (moduleUnit m)]+          else [] +++      map ((text "a reexport in package" <+>)+                .ppr.mkUnit) res +++      if f then [text "a package flag"] else []+      )++cantFindErr using_cabal cannot_find _ unit_env profile tried_these mod_name find_result+  = ptext cannot_find <+> quotes (ppr mod_name)+    $$ more_info+  where+    home_unit  = ue_home_unit unit_env+    more_info+      = case find_result of+            NoPackage pkg+                -> text "no unit id matching" <+> quotes (ppr pkg) <+>+                   text "was found"++            NotFound { fr_paths = files, fr_pkg = mb_pkg+                     , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens+                     , fr_unusables = unusables, fr_suggestions = suggest }+                | Just pkg <- mb_pkg, not (isHomeUnit home_unit pkg)+                -> not_found_in_package pkg files++                | not (null suggest)+                -> pp_suggestions suggest $$ tried_these files++                | null files && null mod_hiddens &&+                  null pkg_hiddens && null unusables+                -> text "It is not a module in the current program, or in any known package."++                | otherwise+                -> vcat (map pkg_hidden pkg_hiddens) $$+                   vcat (map mod_hidden mod_hiddens) $$+                   vcat (map unusable unusables) $$+                   tried_these files++            _ -> panic "cantFindErr"++    build_tag = waysBuildTag (profileWays profile)++    not_found_in_package pkg files+       | build_tag /= ""+       = let+            build = if build_tag == "p" then "profiling"+                                        else "\"" ++ build_tag ++ "\""+         in+         text "Perhaps you haven't installed the " <> text build <>+         text " libraries for package " <> quotes (ppr pkg) <> char '?' $$+         tried_these files++       | otherwise+       = text "There are files missing in the " <> quotes (ppr pkg) <>+         text " package," $$+         text "try running 'ghc-pkg check'." $$+         tried_these files++    pkg_hidden :: Unit -> SDoc+    pkg_hidden uid =+        text "It is a member of the hidden package"+        <+> quotes (ppr uid)+        --FIXME: we don't really want to show the unit id here we should+        -- show the source package id or installed package id if it's ambiguous+        <> dot $$ pkg_hidden_hint uid++    pkg_hidden_hint uid+     | using_cabal+        = let pkg = expectJust "pkg_hidden" (lookupUnit (ue_units unit_env) uid)+           in text "Perhaps you need to add" <+>+              quotes (ppr (unitPackageName pkg)) <+>+              text "to the build-depends in your .cabal file."+     | Just pkg <- lookupUnit (ue_units unit_env) uid+         = text "You can run" <+>+           quotes (text ":set -package " <> ppr (unitPackageName pkg)) <+>+           text "to expose it." $$+           text "(Note: this unloads all the modules in the current scope.)"+     | otherwise = Outputable.empty++    mod_hidden pkg =+        text "it is a hidden module in the package" <+> quotes (ppr pkg)++    unusable (pkg, reason)+      = text "It is a member of the package"+      <+> quotes (ppr pkg)+      $$ pprReason (text "which is") reason++    pp_suggestions :: [ModuleSuggestion] -> SDoc+    pp_suggestions sugs+      | null sugs = Outputable.empty+      | otherwise = hang (text "Perhaps you meant")+                       2 (vcat (map pp_sugg sugs))++    -- NB: Prefer the *original* location, and then reexports, and then+    -- package flags when making suggestions.  ToDo: if the original package+    -- also has a reexport, prefer that one+    pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o+      where provenance ModHidden = Outputable.empty+            provenance (ModUnusable _) = Outputable.empty+            provenance (ModOrigin{ fromOrigUnit = e,+                                   fromExposedReexport = res,+                                   fromPackageFlag = f })+              | Just True <- e+                 = parens (text "from" <+> ppr (moduleUnit mod))+              | f && moduleName mod == m+                 = parens (text "from" <+> ppr (moduleUnit mod))+              | (pkg:_) <- res+                 = parens (text "from" <+> ppr (mkUnit pkg)+                    <> comma <+> text "reexporting" <+> ppr mod)+              | f+                 = parens (text "defined via package flags to be"+                    <+> ppr mod)+              | otherwise = Outputable.empty+    pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o+      where provenance ModHidden =  Outputable.empty+            provenance (ModUnusable _) = Outputable.empty+            provenance (ModOrigin{ fromOrigUnit = e,+                                   fromHiddenReexport = rhs })+              | Just False <- e+                 = parens (text "needs flag -package-id"+                    <+> ppr (moduleUnit mod))+              | (pkg:_) <- rhs+                 = parens (text "needs flag -package-id"+                    <+> ppr (mkUnit pkg))+              | otherwise = Outputable.empty+

@@ -146,9 +146,9 @@       addFingerprints hsc_env partial_iface{ mi_decls = decls }      -- Debug printing-    let unit_state = unitState (hsc_dflags hsc_env)+    let unit_state = hsc_units hsc_env     dumpIfSet_dyn (hsc_dflags hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText-      (pprWithUnitState unit_state $ pprModIface full_iface)+      (pprModIface unit_state full_iface)      return full_iface @@ -372,13 +372,11 @@   where     sort_subs :: AvailInfo -> AvailInfo     sort_subs (Avail n) = Avail n-    sort_subs (AvailTC n [] fs) = AvailTC n [] (sort_flds fs)-    sort_subs (AvailTC n (m:ms) fs)-       | n==m      = AvailTC n (m:sortBy stableNameCmp ms) (sort_flds fs)-       | otherwise = AvailTC n (sortBy stableNameCmp (m:ms)) (sort_flds fs)+    sort_subs (AvailTC n []) = AvailTC n []+    sort_subs (AvailTC n (m:ms))+       | NormalGreName n==m  = AvailTC n (m:sortBy stableGreNameCmp ms)+       | otherwise = AvailTC n (sortBy stableGreNameCmp (m:ms))        -- Maintain the AvailTC Invariant--    sort_flds = sortBy (stableNameCmp `on` flSelector)  {- Note [Original module]

@@ -377,7 +377,7 @@ checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired checkFlagHash hsc_env iface = do     let old_hash = mi_flag_hash (mi_final_exts iface)-    new_hash <- liftIO $ fingerprintDynFlags (hsc_dflags hsc_env)+    new_hash <- liftIO $ fingerprintDynFlags hsc_env                                              (mi_module iface)                                              putNameLiterally     case old_hash == new_hash of@@ -420,12 +420,12 @@ -- If the -unit-id flags change, this can change too. checkMergedSignatures :: ModSummary -> ModIface -> IfG RecompileRequired checkMergedSignatures mod_summary iface = do-    dflags <- getDynFlags+    unit_state <- hsc_units <$> getTopEnv     let old_merged = sort [ mod | UsageMergedRequirement{ usg_mod = mod } <- mi_usages iface ]         new_merged = case Map.lookup (ms_mod_name mod_summary)-                                     (requirementContext (unitState dflags)) of+                                     (requirementContext unit_state) of                         Nothing -> []-                        Just r -> sort $ map (instModuleToModule (unitState dflags)) r+                        Just r -> sort $ map (instModuleToModule unit_state) r     if old_merged == new_merged         then up_to_date (text "signatures to merge in unchanged" $$ ppr new_merged)         else return (RecompBecause "signatures to merge in changed")@@ -1061,7 +1061,7 @@    --   - (some of) dflags    -- it returns two hashes, one that shouldn't change    -- the abi hash and one that should-   flag_hash <- fingerprintDynFlags dflags this_mod putNameLiterally+   flag_hash <- fingerprintDynFlags hsc_env this_mod putNameLiterally     opt_hash <- fingerprintOptFlags dflags putNameLiterally 

@@ -10,8 +10,10 @@  import GHC.Prelude -import GHC.Utils.Binary import GHC.Driver.Session+import GHC.Driver.Env++import GHC.Utils.Binary import GHC.Unit.Module import GHC.Types.Name import GHC.Types.SafeHaskell@@ -29,12 +31,13 @@ -- NB: The 'Module' parameter is the 'Module' recorded by the -- *interface* file, not the actual 'Module' according to our -- 'DynFlags'.-fingerprintDynFlags :: DynFlags -> Module+fingerprintDynFlags :: HscEnv -> Module                     -> (BinHandle -> Name -> IO ())                     -> IO Fingerprint -fingerprintDynFlags dflags@DynFlags{..} this_mod nameio =-    let mainis   = if mainModIs dflags == this_mod then Just mainFunIs else Nothing+fingerprintDynFlags hsc_env this_mod nameio =+    let dflags@DynFlags{..} = hsc_dflags hsc_env+        mainis   = if mainModIs hsc_env == this_mod then Just mainFunIs else Nothing                       -- see #5878         -- pkgopts  = (homeUnit home_unit, sort $ packageFlags dflags)         safeHs   = setSafeMode safeHaskell

@@ -145,7 +145,6 @@     -- because ModIface will never contain module reference for itself     -- in these dependencies.     fmap (nubSort . concat) . T.forM (sel deps) $ \mod -> do-        dflags <- getDynFlags         -- For holes, its necessary to "see through" the instantiation         -- of the hole to get accurate family instance dependencies.         -- For example, if B imports <A>, and <A> is instantiated with@@ -170,7 +169,7 @@         -- not to do it in this case either...)         --         -- This mistake was bug #15594.-        let mod' = renameHoleModule (unitState dflags) hmap mod+        let mod' = renameHoleModule (hsc_units hsc_env) hmap mod         if isHoleModule mod           then do iface <- liftIO . initIfaceCheck (text "rnDepModule") hsc_env                                   $ loadSysInterface (text "rnDepModule") mod'@@ -190,9 +189,8 @@             -> ShIfM a -> IO (Either ErrorMessages a) initRnIface hsc_env iface insts nsubst do_this = do     errs_var <- newIORef emptyBag-    let dflags = hsc_dflags hsc_env-        hsubst = listToUFM insts-        rn_mod = renameHoleModule (unitState dflags) hsubst+    let hsubst = listToUFM insts+        rn_mod = renameHoleModule (hsc_units hsc_env) hsubst         env = ShIfEnv {             sh_if_module = rn_mod (mi_module iface),             sh_if_semantic_module = rn_mod (mi_semantic_module iface),@@ -238,25 +236,30 @@ rnModule :: Rename Module rnModule mod = do     hmap <- getHoleSubst-    dflags <- getDynFlags-    return (renameHoleModule (unitState dflags) hmap mod)+    unit_state <- hsc_units <$> getTopEnv+    return (renameHoleModule unit_state hmap mod)  rnAvailInfo :: Rename AvailInfo-rnAvailInfo (Avail n) = Avail <$> rnIfaceGlobal n-rnAvailInfo (AvailTC n ns fs) = do+rnAvailInfo (Avail c) = Avail <$> rnGreName c+rnAvailInfo (AvailTC n ns) = do     -- Why don't we rnIfaceGlobal the availName itself?  It may not     -- actually be exported by the module it putatively is from, in     -- which case we won't be able to tell what the name actually     -- is.  But for the availNames they MUST be exported, so they     -- will rename fine.-    ns' <- mapM rnIfaceGlobal ns-    fs' <- mapM rnFieldLabel fs-    case ns' ++ map flSelector fs' of+    ns' <- mapM rnGreName ns+    case ns' of         [] -> panic "rnAvailInfoEmpty AvailInfo"-        (rep:rest) -> ASSERT2( all ((== nameModule rep) . nameModule) rest, ppr rep $$ hcat (map ppr rest) ) do-                         n' <- setNameModule (Just (nameModule rep)) n-                         return (AvailTC n' ns' fs')+        (rep:rest) -> ASSERT2( all ((== childModule rep) . childModule) rest, ppr rep $$ hcat (map ppr rest) ) do+                         n' <- setNameModule (Just (childModule rep)) n+                         return (AvailTC n' ns')+  where+    childModule = nameModule . greNameMangledName +rnGreName :: Rename GreName+rnGreName (NormalGreName n) = NormalGreName <$> rnIfaceGlobal n+rnGreName (FieldGreName fl) = FieldGreName  <$> rnFieldLabel fl+ rnFieldLabel :: Rename FieldLabel rnFieldLabel (FieldLabel l b sel) = do     sel' <- rnIfaceGlobal sel@@ -303,13 +306,13 @@ rnIfaceGlobal :: Name -> ShIfM Name rnIfaceGlobal n = do     hsc_env <- getTopEnv-    let dflags = hsc_dflags hsc_env-        home_unit = hsc_home_unit hsc_env+    let unit_state = hsc_units hsc_env+        home_unit  = hsc_home_unit hsc_env     iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv     mb_nsubst <- fmap sh_if_shape getGblEnv     hmap <- getHoleSubst     let m = nameModule n-        m' = renameHoleModule (unitState dflags) hmap m+        m' = renameHoleModule unit_state hmap m     case () of        -- Did we encounter {A.T} while renaming p[A=<B>]:A? If so,        -- do NOT assume B.hi is available.@@ -368,9 +371,9 @@ rnIfaceNeverExported :: Name -> ShIfM Name rnIfaceNeverExported name = do     hmap <- getHoleSubst-    dflags <- getDynFlags+    unit_state <- hsc_units <$> getTopEnv     iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv-    let m = renameHoleModule (unitState dflags) hmap $ nameModule name+    let m = renameHoleModule unit_state hmap $ nameModule name     -- Doublecheck that this DFun/coercion axiom was, indeed, locally defined.     MASSERT2( iface_semantic_mod == m, ppr iface_semantic_mod <+> ppr m )     setNameModule (Just m) name

@@ -384,10 +384,7 @@                    (const ()) $     do  { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags               ; expose_all = gopt Opt_ExposeAllUnfoldings  dflags-              ; print_unqual = mkPrintUnqualified-                                 (unitState dflags)-                                 (hsc_home_unit hsc_env)-                                 rdr_env+              ; print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env               ; implicit_binds = concatMap getImplicitBinds tcs               } 

@@ -16,9 +16,9 @@  import GHC.Driver.Session +import GHC.Unit.Env import GHC.Unit.Types import GHC.Unit.State-import GHC.Utils.Outputable import GHC.Linker.MacOS import GHC.Linker.Unit import GHC.SysTools.Tasks@@ -26,11 +26,11 @@ import qualified Data.Set as Set import System.FilePath -linkDynLib :: DynFlags -> [String] -> [UnitId] -> IO ()-linkDynLib dflags0 o_files dep_packages+linkDynLib :: DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO ()+linkDynLib dflags0 unit_env o_files dep_packages  = do-    let platform = targetPlatform dflags0-        os = platformOS platform+    let platform   = ue_platform unit_env+        os         = platformOS platform          -- This is a rather ugly hack to fix dynamically linked         -- GHC on Windows. If GHC is linked with -threaded, then@@ -47,22 +47,17 @@         verbFlags = getVerbFlags dflags         o_file = outputFile dflags -    pkgs_with_rts <- getPreloadUnitsAnd-               (initSDocContext dflags defaultUserStyle)-               (unitState dflags)-               (mkHomeUnitFromFlags dflags)-               dep_packages+    pkgs_with_rts <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_packages) -    let pkg_lib_paths = collectLibraryPaths (ways dflags) pkgs_with_rts+    let pkg_lib_paths = collectLibraryDirs (ways dflags) pkgs_with_rts     let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths         get_pkg_lib_path_opts l-         | ( osElfTarget (platformOS (targetPlatform dflags)) ||-             osMachOTarget (platformOS (targetPlatform dflags)) ) &&-           dynLibLoader dflags == SystemDependent &&-           -- Only if we want dynamic libraries-           WayDyn `Set.member` ways dflags &&+         | osElfTarget os || osMachOTarget os+         , dynLibLoader dflags == SystemDependent+         , -- Only if we want dynamic libraries+           WayDyn `Set.member` ways dflags            -- Only use RPath if we explicitly asked for it-           gopt Opt_RPath dflags+         , gopt Opt_RPath dflags             = ["-L" ++ l, "-Xlinker", "-rpath", "-Xlinker", l]               -- See Note [-Xlinker -rpath vs -Wl,-rpath]          | otherwise = ["-L" ++ l]@@ -96,8 +91,7 @@     let extra_ld_inputs = ldInputs dflags      -- frameworks-    pkg_framework_opts <- getUnitFrameworkOpts dflags platform-                                              (map unitId pkgs)+    pkg_framework_opts <- getUnitFrameworkOpts unit_env (map unitId pkgs)     let framework_opts = getFrameworkOpts dflags platform      case os of

@@ -20,33 +20,36 @@    ) where +import GHC.Prelude+import GHC.Platform++import GHC.Unit+import GHC.Unit.Env+import GHC.Unit.State+ import GHC.Utils.Asm import GHC.Utils.Error+import GHC.Utils.Misc+import GHC.Utils.Outputable as Outputable+ import GHC.Driver.Session import GHC.Driver.Ppr-import GHC.Unit.State-import GHC.Platform-import GHC.Utils.Outputable as Outputable+ import GHC.Types.SrcLoc ( noSrcSpan )-import GHC.Unit-import GHC.SysTools.Elf-import GHC.Utils.Misc-import GHC.Prelude import qualified GHC.Data.ShortText as ST -import Control.Monad-import Data.Maybe--import Control.Monad.IO.Class-+import GHC.SysTools.Elf import GHC.SysTools.FileCleanup import GHC.SysTools.Tasks import GHC.SysTools.Info import GHC.Linker.Unit-import GHC.Linker.MacOS -mkExtraObj :: DynFlags -> Suffix -> String -> IO FilePath-mkExtraObj dflags extn xs+import Control.Monad.IO.Class+import Control.Monad+import Data.Maybe++mkExtraObj :: DynFlags -> UnitState -> Suffix -> String -> IO FilePath+mkExtraObj dflags unit_state extn xs  = do cFile <- newTempName dflags TFL_CurrentModule extn       oFile <- newTempName dflags TFL_GhcSession "o"       writeFile cFile xs@@ -61,14 +64,12 @@                     else asmOpts ccInfo)       return oFile     where-      pkgs = unitState dflags-       -- Pass a different set of options to the C compiler depending one whether       -- we're compiling C or assembler. When compiling C, we pass the usual       -- set of include directories and PIC flags.       cOpts = map Option (picCCOpts dflags)                     ++ map (FileOption "-I" . ST.unpack)-                            (unitIncludeDirs $ unsafeLookupUnit pkgs rtsUnit)+                            (unitIncludeDirs $ unsafeLookupUnit unit_state rtsUnit)        -- When compiling assembler code, we drop the usual C options, and if the       -- compiler is Clang, we add an extra argument to tell Clang to ignore@@ -86,15 +87,15 @@ -- -- On Windows, when making a shared library we also may need a DllMain. ---mkExtraObjToLinkIntoBinary :: DynFlags -> IO FilePath-mkExtraObjToLinkIntoBinary dflags = do+mkExtraObjToLinkIntoBinary :: DynFlags -> UnitState -> IO FilePath+mkExtraObjToLinkIntoBinary dflags unit_state = do   when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $      putLogMsg dflags NoReason SevInfo noSrcSpan          $ withPprStyle defaultUserStyle          (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$           text "    Call hs_init_ghc() from your main() function to set these options.") -  mkExtraObj dflags "c" (showSDoc dflags main)+  mkExtraObj dflags unit_state "c" (showSDoc dflags main)   where     main       | gopt Opt_NoHsMain dflags = Outputable.empty@@ -152,53 +153,52 @@ -- this was included as inline assembly in the main.c file but this -- is pretty fragile. gas gets upset trying to calculate relative offsets -- that span the .note section (notably .text) when debug info is present-mkNoteObjsToLinkIntoBinary :: DynFlags -> [UnitId] -> IO [FilePath]-mkNoteObjsToLinkIntoBinary dflags dep_packages = do-   link_info <- getLinkInfo dflags dep_packages+mkNoteObjsToLinkIntoBinary :: DynFlags -> UnitEnv -> [UnitId] -> IO [FilePath]+mkNoteObjsToLinkIntoBinary dflags unit_env dep_packages = do+   link_info <- getLinkInfo dflags unit_env dep_packages     if (platformSupportsSavingLinkOpts (platformOS platform ))-     then fmap (:[]) $ mkExtraObj dflags "s" (showSDoc dflags (link_opts link_info))+     then fmap (:[]) $ mkExtraObj dflags unit_state "s" (showSDoc dflags (link_opts link_info))      else return []    where-    platform = targetPlatform dflags-    link_opts info = hcat [-      -- "link info" section (see Note [LinkInfo section])-      makeElfNote platform ghcLinkInfoSectionName ghcLinkInfoNoteName 0 info,+    unit_state = ue_units unit_env+    platform   = ue_platform unit_env+    link_opts info = hcat+        [ -- "link info" section (see Note [LinkInfo section])+          makeElfNote platform ghcLinkInfoSectionName ghcLinkInfoNoteName 0 info -      -- ALL generated assembly must have this section to disable-      -- executable stacks.  See also-      -- "GHC.CmmToAsm" for another instance-      -- where we need to do this.-      if platformHasGnuNonexecStack platform-        then text ".section .note.GNU-stack,\"\","-             <> sectionType platform "progbits" <> char '\n'-        else Outputable.empty-      ]+        -- ALL generated assembly must have this section to disable+        -- executable stacks.  See also+        -- "GHC.CmmToAsm" for another instance+        -- where we need to do this.+        , if platformHasGnuNonexecStack platform+            then text ".section .note.GNU-stack,\"\","+                 <> sectionType platform "progbits" <> char '\n'+            else Outputable.empty+        ]  -- | Return the "link info" string -- -- See Note [LinkInfo section]-getLinkInfo :: DynFlags -> [UnitId] -> IO String-getLinkInfo dflags dep_packages = do-   package_link_opts <- getUnitLinkOpts dflags dep_packages-   let unit_state = unitState dflags-       home_unit  = mkHomeUnitFromFlags dflags-       ctx        = initSDocContext dflags defaultUserStyle-   pkg_frameworks <- if platformUsesFrameworks (targetPlatform dflags)-                     then getUnitFrameworks ctx unit_state home_unit dep_packages-                     else return []-   let extra_ld_inputs = ldInputs dflags-   let-      link_info = (package_link_opts,-                   pkg_frameworks,-                   rtsOpts dflags,-                   rtsOptsEnabled dflags,-                   gopt Opt_NoHsMain dflags,-                   map showOpt extra_ld_inputs,-                   getOpts dflags opt_l)-   ---   return (show link_info)+getLinkInfo :: DynFlags -> UnitEnv -> [UnitId] -> IO String+getLinkInfo dflags unit_env dep_packages = do+    package_link_opts <- getUnitLinkOpts dflags unit_env dep_packages+    pkg_frameworks <- if not (platformUsesFrameworks (ue_platform unit_env))+      then return []+      else do+         ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_packages)+         return (collectFrameworks ps)+    let link_info =+             ( package_link_opts+             , pkg_frameworks+             , rtsOpts dflags+             , rtsOptsEnabled dflags+             , gopt Opt_NoHsMain dflags+             , map showOpt (ldInputs dflags)+             , getOpts dflags opt_l+             )+    return (show link_info)  platformSupportsSavingLinkOpts :: OS -> Bool platformSupportsSavingLinkOpts os@@ -216,9 +216,9 @@  -- Returns 'False' if it was, and we can avoid linking, because the -- previous binary was linked with "the same options".-checkLinkInfo :: DynFlags -> [UnitId] -> FilePath -> IO Bool-checkLinkInfo dflags pkg_deps exe_file- | not (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags)))+checkLinkInfo :: DynFlags -> UnitEnv -> [UnitId] -> FilePath -> IO Bool+checkLinkInfo dflags unit_env pkg_deps exe_file+ | not (platformSupportsSavingLinkOpts (platformOS (ue_platform unit_env)))  -- ToDo: Windows and OS X do not use the ELF binary format, so  -- readelf does not work there.  We need to find another way to do  -- this.@@ -227,7 +227,7 @@                 -- time so we leave it as-is.  | otherwise  = do-   link_info <- getLinkInfo dflags pkg_deps+   link_info <- getLinkInfo dflags unit_env pkg_deps    debugTraceMsg dflags 3 $ text ("Link info: " ++ link_info)    m_exe_link_info <- readElfNoteAsString dflags exe_file                           ghcLinkInfoSectionName ghcLinkInfoNoteName