Compare revisions

Sylvain Henry · Marge Bot · Sylvain Henry · Marge Bot · Sylvain Henry · Marge Bot
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -594,10 +594,10 @@ checkBrokenTablesNextToCode' dflags
 -- flags.  If you are not doing linking or doing static linking, you
 -- can ignore the list of packages returned.
 --
-setSessionDynFlags :: GhcMonad m => DynFlags -> m [UnitId]
+setSessionDynFlags :: GhcMonad m => DynFlags -> m ()
 setSessionDynFlags dflags = do
  dflags' <- checkNewDynFlags dflags
-  (dflags''', preload) <- liftIO $ initPackages dflags'
+  dflags''' <- liftIO $ initUnits dflags'

  -- Interpreter
  interp  <- if gopt Opt_ExternalInterpreter dflags
@@ -637,12 +637,14 @@ setSessionDynFlags dflags = do
                           -- already one set up
                         }
  invalidateModSummaryCache
-  return preload

 -- | Sets the program 'DynFlags'.  Note: this invalidates the internal
 -- cached module graph, causing more work to be done the next time
 -- 'load' is called.
-setProgramDynFlags :: GhcMonad m => DynFlags -> m [UnitId]
+--
+-- Returns a boolean indicating if preload units have changed and need to be
+-- reloaded.
+setProgramDynFlags :: GhcMonad m => DynFlags -> m Bool
 setProgramDynFlags dflags = setProgramDynFlags_ True dflags

 -- | Set the action taken when the compiler produces a message.  This
@@ -654,17 +656,17 @@ setLogAction action = do
  void $ setProgramDynFlags_ False $
    dflags' { log_action = action }

-setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m [UnitId]
+setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m Bool
 setProgramDynFlags_ invalidate_needed dflags = do
  dflags' <- checkNewDynFlags dflags
  dflags_prev <- getProgramDynFlags
-  (dflags'', preload) <-
-    if (packageFlagsChanged dflags_prev dflags')
-       then liftIO $ initPackages dflags'
-       else return (dflags', [])
+  let changed = packageFlagsChanged dflags_prev dflags'
+  dflags'' <- if changed
+               then liftIO $ initUnits dflags'
+               else return dflags'
  modifySession $ \h -> h{ hsc_dflags = dflags'' }
  when invalidate_needed $ invalidateModSummaryCache
-  return preload
+  return changed


 -- When changing the DynFlags, we want the changes to apply to future
@@ -699,7 +701,7 @@ getProgramDynFlags = getSessionDynFlags
 -- | Set the 'DynFlags' used to evaluate interactive expressions.
 -- Note: this cannot be used for changes to packages.  Use
 -- 'setSessionDynFlags', or 'setProgramDynFlags' and then copy the
-- 'pkgState' into the interactive @DynFlags@.
+-- 'unitState' into the interactive @DynFlags@.
 setInteractiveDynFlags :: GhcMonad m => DynFlags -> m ()
 setInteractiveDynFlags dflags = do
  dflags' <- checkNewDynFlags dflags
@@ -1355,7 +1357,7 @@ packageDbModules :: GhcMonad m =>
                 -> m [Module]
 packageDbModules only_exposed = do
   dflags <- getSessionDynFlags
-   let pkgs = eltsUFM (unitInfoMap (pkgState dflags))
+   let pkgs = eltsUFM (unitInfoMap (unitState dflags))
   return $
     [ mkModule pid modname
     | p <- pkgs
@@ -1489,7 +1491,7 @@ findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
 findModule mod_name maybe_pkg = withSession $ \hsc_env -> do
  let
    dflags   = hsc_dflags hsc_env
-    this_pkg = thisPackage dflags
+    this_pkg = homeUnit dflags
  --
  case maybe_pkg of
    Just pkg | fsToUnit pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do
@@ -1677,9 +1679,11 @@ interpretPackageEnv dflags = do
  where
    -- Loading environments (by name or by location)

+    platformArchOs = platformMini (targetPlatform dflags)
+
    namedEnvPath :: String -> MaybeT IO FilePath
    namedEnvPath name = do
-     appdir <- versionedAppDir dflags
+     appdir <- versionedAppDir (programName dflags) platformArchOs
     return $ appdir </> "environments" </> name

    probeEnvName :: String -> MaybeT IO FilePath
@@ -1716,7 +1720,7 @@ interpretPackageEnv dflags = do

    -- e.g. .ghc.environment.x86_64-linux-7.6.3
    localEnvFileName :: FilePath
-    localEnvFileName = ".ghc.environment" <.> versionedFilePath dflags
+    localEnvFileName = ".ghc.environment" <.> versionedFilePath platformArchOs

    -- Search for an env file, starting in the current dir and looking upwards.
    -- Fail if we get to the users home dir or the filesystem root. That is,

--- a/compiler/GHC/Builtin/Names.hs
+++ b/compiler/GHC/Builtin/Names.hs
@@ -144,7 +144,7 @@ When GHC reads the package data base, it (internally only) pretends it has UnitI
 `integer-wired-in` instead of the actual UnitId (which includes the version
 number); just like for `base` and other packages, as described in
 Note [Wired-in units] in GHC.Unit.Module. This is done in
-GHC.Unit.State.findWiredInPackages.
+GHC.Unit.State.findWiredInUnits.
 -}

 {-# LANGUAGE CPP #-}
@@ -614,7 +614,7 @@ rOOT_MAIN       = mkMainModule (fsLit ":Main") -- Root module for initialisation

 mkInteractiveModule :: Int -> Module
 -- (mkInteractiveMoudule 9) makes module 'interactive:M9'
-mkInteractiveModule n = mkModule interactiveUnitId (mkModuleName ("Ghci" ++ show n))
+mkInteractiveModule n = mkModule interactiveUnit (mkModuleName ("Ghci" ++ show n))

 pRELUDE_NAME, mAIN_NAME :: ModuleName
 pRELUDE_NAME   = mkModuleNameFS (fsLit "Prelude")
@@ -625,28 +625,28 @@ dATA_ARRAY_PARALLEL_NAME      = mkModuleNameFS (fsLit "Data.Array.Parallel")
 dATA_ARRAY_PARALLEL_PRIM_NAME = mkModuleNameFS (fsLit "Data.Array.Parallel.Prim")

 mkPrimModule :: FastString -> Module
-mkPrimModule m = mkModule primUnitId (mkModuleNameFS m)
+mkPrimModule m = mkModule primUnit (mkModuleNameFS m)

 mkIntegerModule :: FastString -> Module
-mkIntegerModule m = mkModule integerUnitId (mkModuleNameFS m)
+mkIntegerModule m = mkModule integerUnit (mkModuleNameFS m)

 mkBaseModule :: FastString -> Module
-mkBaseModule m = mkModule baseUnitId (mkModuleNameFS m)
+mkBaseModule m = mkBaseModule_ (mkModuleNameFS m)

 mkBaseModule_ :: ModuleName -> Module
-mkBaseModule_ m = mkModule baseUnitId m
+mkBaseModule_ m = mkModule baseUnit m

 mkThisGhcModule :: FastString -> Module
-mkThisGhcModule m = mkModule thisGhcUnitId (mkModuleNameFS m)
+mkThisGhcModule m = mkThisGhcModule_ (mkModuleNameFS m)

 mkThisGhcModule_ :: ModuleName -> Module
-mkThisGhcModule_ m = mkModule thisGhcUnitId m
+mkThisGhcModule_ m = mkModule thisGhcUnit m

 mkMainModule :: FastString -> Module
-mkMainModule m = mkModule mainUnitId (mkModuleNameFS m)
+mkMainModule m = mkModule mainUnit (mkModuleNameFS m)

 mkMainModule_ :: ModuleName -> Module
-mkMainModule_ m = mkModule mainUnitId m
+mkMainModule_ m = mkModule mainUnit m

 {-
 ************************************************************************

--- a/compiler/GHC/Builtin/Names/TH.hs
+++ b/compiler/GHC/Builtin/Names/TH.hs
@@ -170,7 +170,7 @@ thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib.Internal")
 qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote")

 mkTHModule :: FastString -> Module
-mkTHModule m = mkModule thUnitId (mkModuleNameFS m)
+mkTHModule m = mkModule thUnit (mkModuleNameFS m)

 libFun, libTc, thFun, thTc, thCls, thCon, qqFun :: FastString -> Unique -> Name
 libFun = mk_known_key_name varName  thLib

--- a/compiler/GHC/ByteCode/Linker.hs
+++ b/compiler/GHC/ByteCode/Linker.hs
@@ -169,7 +169,7 @@ nameToCLabel n suffix = mkFastString label
    occPart     = encodeZ (occNameFS (nameOccName n))

    label = concat
-        [ if pkgKey == mainUnitId then "" else packagePart ++ "_"
+        [ if pkgKey == mainUnit then "" else packagePart ++ "_"
        , modulePart
        , '_':occPart
        , '_':suffix

--- a/compiler/GHC/Cmm/CLabel.hs
+++ b/compiler/GHC/Cmm/CLabel.hs
@@ -186,7 +186,7 @@ data CLabel

  -- | A label from a .cmm file that is not associated with a .hs level Id.
  | CmmLabel
-        Unit                    -- what package the label belongs to.
+        UnitId                  -- what package the label belongs to.
        FastString              -- identifier giving the prefix of the label
        CmmLabelInfo            -- encodes the suffix of the label

@@ -552,7 +552,7 @@ mkSRTInfoLabel n = CmmLabel rtsUnitId lbl CmmInfo
 -----
 mkCmmInfoLabel,   mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel,
  mkCmmCodeLabel, mkCmmDataLabel,  mkCmmClosureLabel
-        :: Unit -> FastString -> CLabel
+        :: UnitId -> FastString -> CLabel

 mkCmmInfoLabel      pkg str     = CmmLabel pkg str CmmInfo
 mkCmmEntryLabel     pkg str     = CmmLabel pkg str CmmEntry
@@ -583,7 +583,7 @@ mkApEntryLabel       upd off    = RtsLabel (RtsApEntry           upd off)
 -- A call to some primitive hand written Cmm code
 mkPrimCallLabel :: PrimCall -> CLabel
 mkPrimCallLabel (PrimCall str pkg)
-        = CmmLabel pkg str CmmPrimCall
+        = CmmLabel (toUnitId pkg) str CmmPrimCall


 -- Constructing ForeignLabels
@@ -1032,7 +1032,7 @@ labelDynamic config this_mod lbl =
  case lbl of
   -- is the RTS in a DLL or not?
   RtsLabel _ ->
-     externalDynamicRefs && (this_pkg /= rtsUnitId)
+     externalDynamicRefs && (this_pkg /= rtsUnit)

   IdLabel n _ _ ->
     externalDynamicRefs && isDynLinkName platform this_mod n
@@ -1040,7 +1040,7 @@ labelDynamic config this_mod lbl =
   -- When compiling in the "dyn" way, each package is to be linked into
   -- its own shared library.
   CmmLabel pkg _ _
-    | os == OSMinGW32 -> externalDynamicRefs && (this_pkg /= pkg)
+    | os == OSMinGW32 -> externalDynamicRefs && (toUnitId this_pkg /= pkg)
    | otherwise       -> externalDynamicRefs

   LocalBlockLabel _    -> False
@@ -1169,11 +1169,11 @@ instance Outputable CLabel where

 pprCLabel :: DynFlags -> CLabel -> SDoc
 pprCLabel dflags = \case
-   (LocalBlockLabel u) -> tempLabelPrefixOrUnderscore <> pprUniqueAlways u
+   (LocalBlockLabel u) -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u

   (AsmTempLabel u)
      | not (platformUnregisterised platform)
-      -> tempLabelPrefixOrUnderscore <> pprUniqueAlways u
+      -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u

   (AsmTempDerivedLabel l suf)
      | useNCG
@@ -1231,8 +1231,8 @@ pprCLabel dflags = \case
 pprCLbl :: DynFlags -> CLabel -> SDoc
 pprCLbl dflags = \case
   (StringLitLabel u)   -> pprUniqueAlways u <> text "_str"
-   (SRTLabel u)         -> tempLabelPrefixOrUnderscore <> pprUniqueAlways u <> pp_cSEP <> text "srt"
-   (LargeBitmapLabel u) -> tempLabelPrefixOrUnderscore
+   (SRTLabel u)         -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u <> pp_cSEP <> text "srt"
+   (LargeBitmapLabel u) -> tempLabelPrefixOrUnderscore platform
                           <> char 'b' <> pprUniqueAlways u <> pp_cSEP <> text "btm"
                           -- Some bitmaps for tuple constructors have a numeric tag (e.g. '7')
                           -- until that gets resolved we'll just force them to start
@@ -1242,7 +1242,7 @@ pprCLbl dflags = \case
   (CmmLabel _ str CmmData)     -> ftext str
   (CmmLabel _ str CmmPrimCall) -> ftext str

-   (LocalBlockLabel u) -> tempLabelPrefixOrUnderscore <> text "blk_" <> pprUniqueAlways u
+   (LocalBlockLabel u) -> tempLabelPrefixOrUnderscore platform <> text "blk_" <> pprUniqueAlways u

   (RtsLabel (RtsApFast str)) -> ftext str <> text "_fast"

@@ -1290,7 +1290,7 @@ pprCLbl dflags = \case

   (ForeignLabel str _ _ _) -> ftext str

-   (IdLabel name _cafs flavor) -> internalNamePrefix name <> ppr name <> ppIdFlavor flavor
+   (IdLabel name _cafs flavor) -> internalNamePrefix platform name <> ppr name <> ppIdFlavor flavor

   (CC_Label cc)       -> ppr cc
   (CCS_Label ccs)     -> ppr ccs
@@ -1301,6 +1301,8 @@ pprCLbl dflags = \case
   (DynamicLinkerLabel {})  -> panic "pprCLbl DynamicLinkerLabel"
   (PicBaseLabel {})        -> panic "pprCLbl PicBaseLabel"
   (DeadStripPreventer {})  -> panic "pprCLbl DeadStripPreventer"
+  where
+   platform = targetPlatform dflags

 ppIdFlavor :: IdLabelInfo -> SDoc
 ppIdFlavor x = pp_cSEP <> text
@@ -1331,21 +1333,20 @@ instance Outputable ForeignLabelSource where
        ForeignLabelInThisPackage       -> parens $ text "this package"
        ForeignLabelInExternalPackage   -> parens $ text "external package"

-internalNamePrefix :: Name -> SDoc
-internalNamePrefix name = getPprStyle $ \ sty ->
+internalNamePrefix :: Platform -> Name -> SDoc
+internalNamePrefix platform name = getPprStyle $ \ sty ->
  if asmStyle sty && isRandomGenerated then
-    sdocWithDynFlags $ \dflags ->
-      ptext (asmTempLabelPrefix (targetPlatform dflags))
+      ptext (asmTempLabelPrefix platform)
  else
    empty
  where
    isRandomGenerated = not $ isExternalName name

-tempLabelPrefixOrUnderscore :: SDoc
-tempLabelPrefixOrUnderscore = sdocWithDynFlags $ \dflags ->
+tempLabelPrefixOrUnderscore :: Platform -> SDoc
+tempLabelPrefixOrUnderscore platform =
  getPprStyle $ \ sty ->
   if asmStyle sty then
-      ptext (asmTempLabelPrefix (targetPlatform dflags))
+      ptext (asmTempLabelPrefix platform)
   else
      char '_'


--- a/compiler/GHC/Cmm/Parser.y
+++ b/compiler/GHC/Cmm/Parser.y
@@ -377,7 +377,7 @@ cmmtop  :: { CmmParse () }
        | cmmdata                       { $1 }
        | decl                          { $1 }
        | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'
-                {% liftP . withThisPackage $ \pkg ->
+                {% liftP . withHomeUnitId $ \pkg ->
                   do lits <- sequence $6;
                      staticClosure pkg $3 $5 (map getLit lits) }

@@ -398,7 +398,7 @@ cmmdata :: { CmmParse () }

 data_label :: { CmmParse CLabel }
    : NAME ':'
-                {% liftP . withThisPackage $ \pkg ->
+                {% liftP . withHomeUnitId $ \pkg ->
                   return (mkCmmDataLabel pkg $1) }

 statics :: { [CmmParse [CmmStatic]] }
@@ -455,14 +455,14 @@ maybe_body :: { CmmParse () }

 info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
        : NAME
-                {% liftP . withThisPackage $ \pkg ->
+                {% liftP . withHomeUnitId $ \pkg ->
                   do   newFunctionName $1 pkg
                        return (mkCmmCodeLabel pkg $1, Nothing, []) }


        | 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
                -- ptrs, nptrs, closure type, description, type
-                {% liftP . withThisPackage $ \pkg ->
+                {% liftP . withHomeUnitId $ \pkg ->
                   do dflags <- getDynFlags
                      let prof = profilingInfo dflags $11 $13
                          rep  = mkRTSRep (fromIntegral $9) $
@@ -478,7 +478,7 @@ info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }

        | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
                -- ptrs, nptrs, closure type, description, type, fun type
-                {% liftP . withThisPackage $ \pkg ->
+                {% liftP . withHomeUnitId $ \pkg ->
                   do dflags <- getDynFlags
                      let prof = profilingInfo dflags $11 $13
                          ty   = Fun 0 (ArgSpec (fromIntegral $15))
@@ -496,7 +496,7 @@ info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }

        | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
                -- ptrs, nptrs, tag, closure type, description, type
-                {% liftP . withThisPackage $ \pkg ->
+                {% liftP . withHomeUnitId $ \pkg ->
                   do dflags <- getDynFlags
                      let prof = profilingInfo dflags $13 $15
                          ty  = Constr (fromIntegral $9)  -- Tag
@@ -515,7 +515,7 @@ info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }

        | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
                -- selector, closure type, description, type
-                {% liftP . withThisPackage $ \pkg ->
+                {% liftP . withHomeUnitId $ \pkg ->
                   do dflags <- getDynFlags
                      let prof = profilingInfo dflags $9 $11
                          ty  = ThunkSelector (fromIntegral $5)
@@ -529,7 +529,7 @@ info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }

        | 'INFO_TABLE_RET' '(' NAME ',' INT ')'
                -- closure type (no live regs)
-                {% liftP . withThisPackage $ \pkg ->
+                {% liftP . withHomeUnitId $ \pkg ->
                   do let prof = NoProfilingInfo
                          rep  = mkRTSRep (fromIntegral $5) $ mkStackRep []
                      return (mkCmmRetLabel pkg $3,
@@ -540,7 +540,7 @@ info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }

        | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'
                -- closure type, live regs
-                {% liftP . withThisPackage $ \pkg ->
+                {% liftP . withHomeUnitId $ \pkg ->
                   do dflags <- getDynFlags
                      let platform = targetPlatform dflags
                      live <- sequence $7
@@ -583,9 +583,9 @@ importName
        | 'CLOSURE' NAME
        { ($2, mkForeignLabel $2 Nothing ForeignLabelInExternalPackage IsData) }

-        -- A label imported with an explicit packageId.
+        -- A label imported with an explicit UnitId.
        | STRING NAME
-        { ($2, mkCmmCodeLabel (fsToUnit (mkFastString $1)) $2) }
+        { ($2, mkCmmCodeLabel (UnitId (mkFastString $1)) $2) }


 names   :: { [FastString] }
@@ -1163,7 +1163,7 @@ profilingInfo dflags desc_str ty_str
    then NoProfilingInfo
    else ProfilingInfo (BS8.pack desc_str) (BS8.pack ty_str)

-staticClosure :: Unit -> FastString -> FastString -> [CmmLit] -> CmmParse ()
+staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse ()
 staticClosure pkg cl_label info payload
  = do dflags <- getDynFlags
       let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []

--- a/compiler/GHC/CmmToAsm/Config.hs
+++ b/compiler/GHC/CmmToAsm/Config.hs
@@ -9,12 +9,10 @@ where
 import GHC.Prelude
 import GHC.Platform
 import GHC.Cmm.Type (Width(..))
-import GHC.Unit.Module

 -- | Native code generator configuration
 data NCGConfig = NCGConfig
   { ncgPlatform              :: !Platform        -- ^ Target platform
-   , ncgUnitId                :: Unit             -- ^ Target unit ID
   , ncgProcAlignment         :: !(Maybe Int)     -- ^ Mandatory proc alignment
   , ncgDebugLevel            :: !Int             -- ^ Debug level
   , ncgExternalDynamicRefs   :: !Bool            -- ^ Generate code to link against dynamic libraries

--- a/compiler/GHC/CmmToAsm/Monad.hs
+++ b/compiler/GHC/CmmToAsm/Monad.hs
@@ -149,7 +149,6 @@ mkNatM_State us delta dflags this_mod
 initConfig :: DynFlags -> NCGConfig
 initConfig dflags = NCGConfig
   { ncgPlatform              = targetPlatform dflags
-   , ncgUnitId                = thisPackage dflags
   , ncgProcAlignment         = cmmProcAlignment dflags
   , ncgDebugLevel            = debugLevel dflags
   , ncgExternalDynamicRefs   = gopt Opt_ExternalDynamicRefs dflags

--- a/compiler/GHC/CmmToLlvm.hs
+++ b/compiler/GHC/CmmToLlvm.hs
@@ -92,7 +92,8 @@ llvmCodeGen' dflags cmm_stream
        a <- Stream.consume cmm_stream llvmGroupLlvmGens

        -- Declare aliases for forward references
-        renderLlvm . pprLlvmData =<< generateExternDecls
+        opts <- getLlvmOpts
+        renderLlvm . pprLlvmData opts =<< generateExternDecls

        -- Postamble
        cmmUsedLlvmGens
@@ -150,14 +151,15 @@ cmmDataLlvmGens statics
       mapM_ regGlobal gs
       gss' <- mapM aliasify $ gs

-       renderLlvm $ pprLlvmData (concat gss', concat tss)
+       opts <- getLlvmOpts
+       renderLlvm $ pprLlvmData opts (concat gss', concat tss)

 -- | Complete LLVM code generation phase for a single top-level chunk of Cmm.
 cmmLlvmGen ::RawCmmDecl -> LlvmM ()
 cmmLlvmGen cmm@CmmProc{} = do

    -- rewrite assignments to global regs
-    dflags <- getDynFlag id
+    dflags <- getDynFlags
    let fixed_cmm = {-# SCC "llvm_fix_regs" #-} fixStgRegisters dflags cmm

    dumpIfSetLlvm Opt_D_dump_opt_cmm "Optimised Cmm"
@@ -194,7 +196,8 @@ cmmMetaLlvmPrelude = do
              -- just a name on its own. Previously `null` was accepted as the
              -- name.
              Nothing -> [ MetaStr name ]
-  renderLlvm $ ppLlvmMetas metas
+  opts <- getLlvmOpts
+  renderLlvm $ ppLlvmMetas opts metas

 -- -----------------------------------------------------------------------------
 -- | Marks variables as used where necessary
@@ -217,6 +220,7 @@ cmmUsedLlvmGens = do
      sectName  = Just $ fsLit "llvm.metadata"
      lmUsedVar = LMGlobalVar (fsLit "llvm.used") ty Appending sectName Nothing Constant
      lmUsed    = LMGlobal lmUsedVar (Just usedArray)
+  opts <- getLlvmOpts
  if null ivars
     then return ()
-     else renderLlvm $ pprLlvmData ([lmUsed], [])
+     else renderLlvm $ pprLlvmData opts ([lmUsed], [])
--- a/compiler/GHC/CmmToLlvm/Base.hs
+++ b/compiler/GHC/CmmToLlvm/Base.hs
@@ -21,9 +21,9 @@ module GHC.CmmToLlvm.Base (
        LlvmM,
        runLlvm, liftStream, withClearVars, varLookup, varInsert,
        markStackReg, checkStackReg,
-        funLookup, funInsert, getLlvmVer, getDynFlags, getDynFlag, getLlvmPlatform,
+        funLookup, funInsert, getLlvmVer, getDynFlags,
        dumpIfSetLlvm, renderLlvm, markUsedVar, getUsedVars,
-        ghcInternalFunctions, getPlatform,
+        ghcInternalFunctions, getPlatform, getLlvmOpts,

        getMetaUniqueId,
        setUniqMeta, getUniqMeta,
@@ -114,10 +114,10 @@ widthToLlvmInt :: Width -> LlvmType
 widthToLlvmInt w = LMInt $ widthInBits w

 -- | GHC Call Convention for LLVM
-llvmGhcCC :: DynFlags -> LlvmCallConvention
-llvmGhcCC dflags
- | platformUnregisterised (targetPlatform dflags) = CC_Ccc
- | otherwise                                      = CC_Ghc
+llvmGhcCC :: Platform -> LlvmCallConvention
+llvmGhcCC platform
+ | platformUnregisterised platform = CC_Ccc
+ | otherwise                       = CC_Ghc

 -- | Llvm Function type for Cmm function
 llvmFunTy :: LiveGlobalRegs -> LlvmM LlvmType
@@ -133,9 +133,8 @@ llvmFunSig' :: LiveGlobalRegs -> LMString -> LlvmLinkageType -> LlvmM LlvmFuncti
 llvmFunSig' live lbl link
  = do let toParams x | isPointer x = (x, [NoAlias, NoCapture])
                      | otherwise   = (x, [])
-       dflags <- getDynFlags
       platform <- getPlatform
-       return $ LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs
+       return $ LlvmFunctionDecl lbl link (llvmGhcCC platform) LMVoid FixedArgs
                                 (map (toParams . getVarType) (llvmFunArgs platform live))
                                 (llvmFunAlign platform)

@@ -148,10 +147,10 @@ llvmInfAlign :: Platform -> LMAlign
 llvmInfAlign platform = Just (platformWordSizeInBytes platform)

 -- | Section to use for a function
-llvmFunSection :: DynFlags -> LMString -> LMSection
-llvmFunSection dflags lbl
-    | gopt Opt_SplitSections dflags = Just (concatFS [fsLit ".text.", lbl])
-    | otherwise                     = Nothing
+llvmFunSection :: LlvmOpts -> LMString -> LMSection
+llvmFunSection opts lbl
+    | llvmOptsSplitSections opts = Just (concatFS [fsLit ".text.", lbl])
+    | otherwise                  = Nothing

 -- | A Function's arguments
 llvmFunArgs :: Platform -> LiveGlobalRegs -> [LlvmVar]
@@ -311,6 +310,7 @@ llvmVersionList = NE.toList . llvmVersionNE

 data LlvmEnv = LlvmEnv
  { envVersion :: LlvmVersion      -- ^ LLVM version
+  , envOpts    :: LlvmOpts         -- ^ LLVM backend options
  , envDynFlags :: DynFlags        -- ^ Dynamic flags
  , envOutput :: BufHandle         -- ^ Output buffer
  , envMask :: !Char               -- ^ Mask for creating unique values
@@ -342,8 +342,13 @@ instance Monad LlvmM where
 instance HasDynFlags LlvmM where
    getDynFlags = LlvmM $ \env -> return (envDynFlags env, env)

+-- | Get target platform
 getPlatform :: LlvmM Platform
-getPlatform = targetPlatform <$> getDynFlags
+getPlatform = llvmOptsPlatform <$> getLlvmOpts
+
+-- | Get LLVM options
+getLlvmOpts :: LlvmM LlvmOpts
+getLlvmOpts = LlvmM $ \env -> return (envOpts env, env)

 instance MonadUnique LlvmM where
    getUniqueSupplyM = do
@@ -370,6 +375,7 @@ runLlvm dflags ver out m = do
                      , envUsedVars = []
                      , envAliases = emptyUniqSet
                      , envVersion = ver
+                      , envOpts = initLlvmOpts dflags
                      , envDynFlags = dflags
                      , envOutput = out
                      , envMask = 'n'
@@ -426,14 +432,6 @@ getMetaUniqueId = LlvmM $ \env ->
 getLlvmVer :: LlvmM LlvmVersion
 getLlvmVer = getEnv envVersion

-- | Get the platform we are generating code for
-getDynFlag :: (DynFlags -> a) -> LlvmM a
-getDynFlag f = getEnv (f . envDynFlags)
-
-- | Get the platform we are generating code for
-getLlvmPlatform :: LlvmM Platform
-getLlvmPlatform = getDynFlag targetPlatform
-
 -- | Dumps the document if the corresponding flag has been set by the user
 dumpIfSetLlvm :: DumpFlag -> String -> DumpFormat -> Outp.SDoc -> LlvmM ()
 dumpIfSetLlvm flag hdr fmt doc = do

--- a/compiler/GHC/CmmToLlvm/CodeGen.hs
+++ b/compiler/GHC/CmmToLlvm/CodeGen.hs
@@ -178,7 +178,7 @@ barrier = do
 --   exceptions (where no code will be emitted instead).
 barrierUnless :: [Arch] -> LlvmM StmtData
 barrierUnless exs = do
-    platform <- getLlvmPlatform
+    platform <- getPlatform
    if platformArch platform `elem` exs
        then return (nilOL, [])
        else barrier
@@ -415,7 +415,7 @@ genCall target res args = do
                        ++ " 0 or 1, given " ++ show (length t) ++ "."

    -- extract Cmm call convention, and translate to LLVM call convention
-    platform <- lift $ getLlvmPlatform
+    platform <- lift $ getPlatform
    let lmconv = case target of
            ForeignTarget _ (ForeignConvention conv _ _ _) ->
              case conv of
@@ -993,6 +993,7 @@ genStore_slow addr val meta = do
    let stmts = stmts1 `appOL` stmts2
    dflags <- getDynFlags
    platform <- getPlatform
+    opts <- getLlvmOpts
    case getVarType vaddr of
        -- sometimes we need to cast an int to a pointer before storing
        LMPointer ty@(LMPointer _) | getVarType vval == llvmWord platform -> do
@@ -1015,7 +1016,7 @@ genStore_slow addr val meta = do
                    (PprCmm.pprExpr platform addr <+> text (
                        "Size of Ptr: " ++ show (llvmPtrBits platform) ++
                        ", Size of var: " ++ show (llvmWidthInBits platform other) ++
-                        ", Var: " ++ showSDoc dflags (ppr vaddr)))
+                        ", Var: " ++ showSDoc dflags (ppVar opts vaddr)))


 -- | Unconditional branch
@@ -1041,7 +1042,8 @@ genCondBranch cond idT idF likely = do
            return (stmts1 `appOL` stmts2 `snocOL` s1, top1 ++ top2)
        else do
            dflags <- getDynFlags
-            panic $ "genCondBranch: Cond expr not bool! (" ++ showSDoc dflags (ppr vc) ++ ")"
+            opts <- getLlvmOpts
+            panic $ "genCondBranch: Cond expr not bool! (" ++ showSDoc dflags (ppVar opts vc) ++ ")"


 -- | Generate call to llvm.expect.x intrinsic. Assigning result to a new var.
@@ -1663,6 +1665,7 @@ genLoad_slow :: Atomic -> CmmExpr -> CmmType -> [MetaAnnot] -> LlvmM ExprData
 genLoad_slow atomic e ty meta = do
  platform <- getPlatform
  dflags <- getDynFlags
+  opts <- getLlvmOpts
  runExprData $ do
    iptr <- exprToVarW e
    case getVarType iptr of
@@ -1678,7 +1681,7 @@ genLoad_slow atomic e ty meta = do
                        (PprCmm.pprExpr platform e <+> text (
                            "Size of Ptr: " ++ show (llvmPtrBits platform) ++
                            ", Size of var: " ++ show (llvmWidthInBits platform other) ++
-                            ", Var: " ++ showSDoc dflags (ppr iptr)))
+                            ", Var: " ++ showSDoc dflags (ppVar opts iptr)))
  where
    loadInstr ptr | atomic    = ALoad SyncSeqCst False ptr
                  | otherwise = Load ptr
@@ -1873,7 +1876,7 @@ funEpilogue live = do
        loadUndef r = do
          let ty = (pLower . getVarType $ lmGlobalRegVar platform r)
          return (Just $ LMLitVar $ LMUndefLit ty, nilOL)
-    platform <- getDynFlag targetPlatform
+    platform <- getPlatform
    let allRegs = activeStgRegs platform
    loads <- flip mapM allRegs $ \r -> case () of
      _ | (False, r) `elem` livePadded

--- a/compiler/GHC/CmmToLlvm/Data.hs
+++ b/compiler/GHC/CmmToLlvm/Data.hs
@@ -17,7 +17,6 @@ import GHC.CmmToLlvm.Base
 import GHC.Cmm.BlockId
 import GHC.Cmm.CLabel
 import GHC.Cmm
-import GHC.Driver.Session
 import GHC.Platform

 import GHC.Data.FastString
@@ -71,7 +70,7 @@ genLlvmData (sec, CmmStaticsRaw lbl xs) = do
    label <- strCLabel_llvm lbl
    static <- mapM genData xs
    lmsec <- llvmSection sec
-    platform <- getLlvmPlatform
+    platform <- getPlatform
    let types   = map getStatType static

        strucTy = LMStruct types
@@ -113,9 +112,9 @@ llvmSectionType p t = case t of
 -- | Format a Cmm Section into a LLVM section name
 llvmSection :: Section -> LlvmM LMSection
 llvmSection (Section t suffix) = do
-  dflags <- getDynFlags
-  let splitSect = gopt Opt_SplitSections dflags
-      platform  = targetPlatform dflags
+  opts <- getLlvmOpts
+  let splitSect = llvmOptsSplitSections opts
+      platform  = llvmOptsPlatform opts
  if not splitSect
  then return Nothing
  else do

--- a/compiler/GHC/CmmToLlvm/Ppr.hs
+++ b/compiler/GHC/CmmToLlvm/Ppr.hs
@@ -27,21 +27,22 @@ import GHC.Types.Unique
 --

 -- | Pretty print LLVM data code
-pprLlvmData :: LlvmData -> SDoc
-pprLlvmData (globals, types) =
+pprLlvmData :: LlvmOpts -> LlvmData -> SDoc
+pprLlvmData opts (globals, types) =
    let ppLlvmTys (LMAlias    a) = ppLlvmAlias a
        ppLlvmTys (LMFunction f) = ppLlvmFunctionDecl f
        ppLlvmTys _other         = empty

        types'   = vcat $ map ppLlvmTys types
-        globals' = ppLlvmGlobals globals
+        globals' = ppLlvmGlobals opts globals
    in types' $+$ globals'


 -- | Pretty print LLVM code
 pprLlvmCmmDecl :: LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar])
-pprLlvmCmmDecl (CmmData _ lmdata)
-  = return (vcat $ map pprLlvmData lmdata, [])
+pprLlvmCmmDecl (CmmData _ lmdata) = do
+  opts <- getLlvmOpts
+  return (vcat $ map (pprLlvmData opts) lmdata, [])

 pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks))
  = do let lbl = case mb_info of
@@ -55,10 +56,11 @@ pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks))

       funDec <- llvmFunSig live lbl link
       dflags <- getDynFlags
+       opts <- getLlvmOpts
       platform <- getPlatform
-       let buildArg = fsLit . showSDoc dflags . ppPlainName
+       let buildArg = fsLit . showSDoc dflags . ppPlainName opts
           funArgs = map buildArg (llvmFunArgs platform live)
-           funSect = llvmFunSection dflags (decName funDec)
+           funSect = llvmFunSection opts (decName funDec)

       -- generate the info table
       prefix <- case mb_info of
@@ -92,7 +94,7 @@ pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks))
                            (Just $ LMBitc (LMStaticPointer defVar)
                                           i8Ptr)

-       return (ppLlvmGlobal alias $+$ ppLlvmFunction platform fun', [])
+       return (ppLlvmGlobal opts alias $+$ ppLlvmFunction opts fun', [])


 -- | The section we are putting info tables and their entry code into, should

--- a/compiler/GHC/Core/Opt/DmdAnal.hs
+++ b/compiler/GHC/Core/Opt/DmdAnal.hs
@@ -62,9 +62,10 @@ dmdAnalTopBind :: AnalEnv
               -> CoreBind
               -> (AnalEnv, CoreBind)
 dmdAnalTopBind env (NonRec id rhs)
-  = (extendAnalEnv TopLevel env id' (idStrictness id'), NonRec id' rhs')
+  = ( extendAnalEnv TopLevel env id sig
+    , NonRec (setIdStrictness id sig) rhs')
  where
-    ( _, id', rhs') = dmdAnalRhsLetDown Nothing env cleanEvalDmd id rhs
+    ( _, sig, rhs') = dmdAnalRhsLetDown Nothing env cleanEvalDmd id rhs

 dmdAnalTopBind env (Rec pairs)
  = (env', Rec pairs')
@@ -216,10 +217,8 @@ dmdAnal' env dmd (Case scrut case_bndr ty [(DataAlt dc, bndrs, rhs)])
  -- Only one alternative with a product constructor
  | let tycon = dataConTyCon dc
  , isJust (isDataProductTyCon_maybe tycon)
-  , Just rec_tc' <- checkRecTc (ae_rec_tc env) tycon
  = let
-        env_alt                  = env { ae_rec_tc = rec_tc' }
-        (rhs_ty, rhs')           = dmdAnal env_alt dmd rhs
+        (rhs_ty, rhs')           = dmdAnal env dmd rhs
        (alt_ty1, dmds)          = findBndrsDmds env rhs_ty bndrs
        (alt_ty2, case_bndr_dmd) = findBndrDmd env False alt_ty1 case_bndr
        id_dmds                  = addCaseBndrDmd case_bndr_dmd dmds
@@ -299,8 +298,9 @@ dmdAnal' env dmd (Let (NonRec id rhs) body)
 dmdAnal' env dmd (Let (NonRec id rhs) body)
  = (body_ty2, Let (NonRec id2 rhs') body')
  where
-    (lazy_fv, id1, rhs') = dmdAnalRhsLetDown Nothing env dmd id rhs
-    env1                 = extendAnalEnv NotTopLevel env id1 (idStrictness id1)
+    (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]
@@ -509,95 +509,11 @@ dmdTransform env var dmd
  = -- pprTrace "dmdTransform:other" (vcat [ppr var, ppr sig, ppr dmd, ppr res]) $
    unitDmdType (unitVarEnv var (mkOnceUsedDmd dmd))

-{-
-************************************************************************
+{- *********************************************************************
 *                                                                      *
-\subsection{Bindings}
+                      Binding right-hand sides
 *                                                                      *
-************************************************************************
-}
-
-- Recursive bindings
-dmdFix :: TopLevelFlag
-       -> AnalEnv                            -- Does not include bindings for this binding
-       -> CleanDemand
-       -> [(Id,CoreExpr)]
-       -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with strictness info
-
-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
-
-    -- If fixed-point iteration does not yield a result we use this instead
-    -- See Note [Safe abortion in the fixed-point iteration]
-    abort :: (AnalEnv, DmdEnv, [(Id,CoreExpr)])
-    abort = (env, lazy_fv', zapped_pairs)
-      where (lazy_fv, pairs') = step True (zapIdStrictness orig_pairs)
-            -- Note [Lazy and unleashable free variables]
-            non_lazy_fvs = plusVarEnvList $ map (strictSigDmdEnv . idStrictness . fst) pairs'
-            lazy_fv'     = lazy_fv `plusVarEnv` mapVarEnv (const topDmd) non_lazy_fvs
-            zapped_pairs = zapIdStrictness pairs'
-
-    -- The fixed-point varies the idStrictness field of the binders, and terminates if that
-    -- annotation does not change any more.
-    loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, DmdEnv, [(Id,CoreExpr)])
-    loop n pairs
-      | found_fixpoint = (final_anal_env, lazy_fv, pairs')
-      | n == 10        = abort
-      | otherwise      = loop (n+1) pairs'
-      where
-        found_fixpoint    = map (idStrictness . fst) pairs' == map (idStrictness . fst) pairs
-        first_round       = n == 1
-        (lazy_fv, pairs') = step first_round pairs
-        final_anal_env    = extendAnalEnvs top_lvl env (map fst pairs')
-
-    step :: Bool -> [(Id, CoreExpr)] -> (DmdEnv, [(Id, CoreExpr)])
-    step first_round pairs = (lazy_fv, pairs')
-      where
-        -- In all but the first iteration, delete the virgin flag
-        start_env | first_round = env
-                  | otherwise   = nonVirgin env
-
-        start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyDmdEnv)
-
-        ((_,lazy_fv), pairs') = mapAccumL my_downRhs start pairs
-                -- mapAccumL: Use the new signature to do the next pair
-                -- The occurrence analyser has arranged them in a good order
-                -- so this can significantly reduce the number of iterations needed
-
-        my_downRhs (env, lazy_fv) (id,rhs)
-          = ((env', lazy_fv'), (id', rhs'))
-          where
-            (lazy_fv1, id', rhs') = dmdAnalRhsLetDown (Just bndrs) env let_dmd id rhs
-            lazy_fv'              = plusVarEnv_C bothDmd lazy_fv lazy_fv1
-            env'                  = extendAnalEnv top_lvl env id (idStrictness id')
-
-
-    zapIdStrictness :: [(Id, CoreExpr)] -> [(Id, CoreExpr)]
-    zapIdStrictness pairs = [(setIdStrictness id nopSig, rhs) | (id, rhs) <- pairs ]
-
-{-
-Note [Safe abortion in the fixed-point iteration]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Fixed-point iteration may fail to terminate. But we cannot simply give up and
-return the environment and code unchanged! We still need to do one additional
-round, for two reasons:
-
- * To get information on used free variables (both lazy and strict!)
-   (see Note [Lazy and unleashable free variables])
- * To ensure that all expressions have been traversed at least once, and any left-over
-   strictness annotations have been updated.
-
-This final iteration does not add the variables to the strictness signature
-environment, which effectively assigns them 'nopSig' (see "getStrictness")
-
-}
+********************************************************************* -}

 -- Let bindings can be processed in two ways:
 -- Down (RHS before body) or Up (body before RHS).
@@ -615,30 +531,26 @@ dmdAnalRhsLetDown
  :: Maybe [Id]   -- Just bs <=> recursive, Nothing <=> non-recursive
  -> AnalEnv -> CleanDemand
  -> Id -> CoreExpr
-  -> (DmdEnv, Id, CoreExpr)
+  -> (DmdEnv, StrictSig, 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
-  = (lazy_fv, id', rhs')
+  = (lazy_fv, sig, rhs')
  where
-    rhs_arity      = idArity id
-    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
-      | otherwise
-      -- NB: rhs_arity
-      -- See Note [Demand signatures are computed for a threshold demand based on idArity]
-      = mkRhsDmd env rhs_arity rhs
-    (DmdType rhs_fv rhs_dmds rhs_div, rhs')
-                   = dmdAnal env rhs_dmd rhs
-    sig            = mkStrictSigForArity rhs_arity (DmdType sig_fv rhs_dmds rhs_div)
-    id'            = -- pprTrace "dmdAnalRhsLetDown" (ppr id <+> ppr sig) $
-                     setIdStrictness id sig
-        -- See Note [NOINLINE and strictness]
-
+    rhs_arity = idArity id
+    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
+            | otherwise
+            -- NB: rhs_arity
+            -- See Note [Demand signatures are computed for a threshold demand based on idArity]
+            = mkRhsDmd env rhs_arity rhs
+
+    (DmdType rhs_fv rhs_dmds rhs_div, rhs') = dmdAnal env rhs_dmd rhs
+    sig = mkStrictSigForArity rhs_arity (DmdType sig_fv rhs_dmds rhs_div)

    -- See Note [Aggregated demand for cardinality]
    rhs_fv1 = case rec_flag of
@@ -912,14 +824,152 @@ That motivated using a demand of C(C(C(S(L,L)))) for the RHS, where
 behaviour -- see #17932.   Happily it turns out now to be entirely
 unnecessary: we get good results with C(C(C(S))).   So I simply
 deleted the special case.
+-}

-************************************************************************
+{- *********************************************************************
 *                                                                      *
-\subsection{Strictness signatures and types}
+                      Fixpoints
 *                                                                      *
-************************************************************************
+********************************************************************* -}
+
+-- Recursive bindings
+dmdFix :: TopLevelFlag
+       -> AnalEnv                            -- Does not include bindings for this binding
+       -> CleanDemand
+       -> [(Id,CoreExpr)]
+       -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with strictness info
+
+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
+
+    -- If fixed-point iteration does not yield a result we use this instead
+    -- See Note [Safe abortion in the fixed-point iteration]
+    abort :: (AnalEnv, DmdEnv, [(Id,CoreExpr)])
+    abort = (env, lazy_fv', zapped_pairs)
+      where (lazy_fv, pairs') = step True (zapIdStrictness orig_pairs)
+            -- Note [Lazy and unleashable free variables]
+            non_lazy_fvs = plusVarEnvList $ map (strictSigDmdEnv . idStrictness . fst) pairs'
+            lazy_fv'     = lazy_fv `plusVarEnv` mapVarEnv (const topDmd) non_lazy_fvs
+            zapped_pairs = zapIdStrictness pairs'
+
+    -- The fixed-point varies the idStrictness field of the binders, and terminates if that
+    -- annotation does not change any more.
+    loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, DmdEnv, [(Id,CoreExpr)])
+    loop n pairs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idStrictness id)
+                   --                                     | (id,_)<- pairs]) $
+                   loop' n pairs
+
+    loop' n pairs
+      | found_fixpoint = (final_anal_env, lazy_fv, pairs')
+      | n == 10        = abort
+      | otherwise      = loop (n+1) pairs'
+      where
+        found_fixpoint    = map (idStrictness . fst) pairs' == map (idStrictness . fst) pairs
+        first_round       = n == 1
+        (lazy_fv, pairs') = step first_round pairs
+        final_anal_env    = extendAnalEnvs top_lvl env (map fst pairs')
+
+    step :: Bool -> [(Id, CoreExpr)] -> (DmdEnv, [(Id, CoreExpr)])
+    step first_round pairs = (lazy_fv, pairs')
+      where
+        -- In all but the first iteration, delete the virgin flag
+        start_env | first_round = env
+                  | otherwise   = nonVirgin env
+
+        start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyDmdEnv)
+
+        ((_,lazy_fv), pairs') = mapAccumL my_downRhs start pairs
+                -- mapAccumL: Use the new signature to do the next pair
+                -- The occurrence analyser has arranged them in a good order
+                -- so this can significantly reduce the number of iterations needed
+
+        my_downRhs (env, lazy_fv) (id,rhs)
+          = ((env', lazy_fv'), (id', rhs'))
+          where
+            (lazy_fv1, sig, rhs') = dmdAnalRhsLetDown (Just bndrs) env let_dmd id rhs
+            lazy_fv'              = plusVarEnv_C bothDmd lazy_fv lazy_fv1
+            env'                  = extendAnalEnv top_lvl env id sig
+            id'                   = setIdStrictness id sig
+
+    zapIdStrictness :: [(Id, CoreExpr)] -> [(Id, CoreExpr)]
+    zapIdStrictness pairs = [(setIdStrictness id nopSig, rhs) | (id, rhs) <- pairs ]
+
+{- Note [Safe abortion in the fixed-point iteration]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Fixed-point iteration may fail to terminate. But we cannot simply give up and
+return the environment and code unchanged! We still need to do one additional
+round, for two reasons:
+
+ * To get information on used free variables (both lazy and strict!)
+   (see Note [Lazy and unleashable free variables])
+ * To ensure that all expressions have been traversed at least once, and any left-over
+   strictness annotations have been updated.
+
+This final iteration does not add the variables to the strictness signature
+environment, which effectively assigns them 'nopSig' (see "getStrictness")
+
+Note [Trimming a demand to a type]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+There are two reasons we sometimes trim a demand to match a type.
+  1. GADTs
+  2. Recursive products and widening
+
+More on both below.  But the botttom line is: we really don't want to
+have a binder whose demand is more deeply-nested than its type
+"allows". So in findBndrDmd we call trimToType and findTypeShape to
+trim the demand on the binder to a form that matches the type
+
+Now to the reasons. For (1) consider
+  f :: a -> Bool
+  f x = case ... of
+          A g1 -> case (x |> g1) of (p,q) -> ...
+          B    -> error "urk"
+
+where A,B are the constructors of a GADT.  We'll get a U(U,U) demand
+on x from the A branch, but that's a stupid demand for x itself, which
+has type 'a'. Indeed we get ASSERTs going off (notably in
+splitUseProdDmd, #8569).
+
+For (2) consider
+  data T = MkT Int T    -- A recursive product
+  f :: Int -> T -> Int
+  f 0 _         = 0
+  f _ (MkT n t) = f n t
+
+Here f is lazy in T, but its *usage* is infinite: U(U,U(U,U(U, ...))).
+Notice that this happens becuase T is a product type, and is recrusive.
+If we are not careful, we'll fail to iterate to a fixpoint in dmdFix,
+and bale out entirely, which is inefficient and over-conservative.
+
+Worse, as we discovered in #18304, the size of the usages we compute
+can grow /exponentially/, so even 10 iterations costs far too much.
+Especially since we then discard the result.
+
+To avoid this we use the same findTypeShape function as for (1), but
+arrange that it trims the demand if it encounters the same type constructor
+twice (or three times, etc).  We use our standard RecTcChecker mechanism
+for this -- see GHC.Core.Opt.WorkWrap.Utils.findTypeShape.
+
+This is usually call "widening".  We could do it just in dmdFix, but
+since are doing this findTypeShape business /anyway/ because of (1),
+and it has all the right information to hand, it's extremely
+convenient to do it there.
+
 -}

+{- *********************************************************************
+*                                                                      *
+                 Strictness signatures and types
+*                                                                      *
+********************************************************************* -}
+
 unitDmdType :: DmdEnv -> DmdType
 unitDmdType dmd_env = DmdType dmd_env [] topDiv

@@ -1133,7 +1183,6 @@ data AnalEnv
       , ae_sigs   :: SigEnv
       , ae_virgin :: Bool    -- True on first iteration only
                              -- See Note [Initialising strictness]
-       , ae_rec_tc :: RecTcChecker
       , ae_fam_envs :: FamInstEnvs
 }

@@ -1157,7 +1206,6 @@ emptyAnalEnv dflags fam_envs
    = AE { ae_dflags = dflags
         , ae_sigs = emptySigEnv
         , ae_virgin = True
-         , ae_rec_tc = initRecTc
         , ae_fam_envs = fam_envs
         }

@@ -1199,7 +1247,7 @@ findBndrsDmds env dmd_ty bndrs
      | otherwise = go dmd_ty bs

 findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> (DmdType, Demand)
-- See Note [Trimming a demand to a type] in GHC.Types.Demand
+-- See Note [Trimming a demand to a type]
 findBndrDmd env arg_of_dfun dmd_ty id
  = (dmd_ty', dmd')
  where

--- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
+++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
@@ -231,7 +231,7 @@ A simplified example is #11565#comment:6

 Current strategy is very simple: don't perform w/w transformation at all
 if the result produces a wrapper with arity higher than -fmax-worker-args
-and the number arguments before w/w.
+and the number arguments before w/w (see #18122).

 It is a bit all or nothing, consider

@@ -248,6 +248,7 @@ solve f. But we can get a lot of args from deeply-nested products:
 This is harder to spot on an arg-by-arg basis. Previously mkWwStr was
 given some "fuel" saying how many arguments it could add; when we ran
 out of fuel it would stop w/wing.
+
 Still not very clever because it had a left-right bias.

 ************************************************************************
@@ -567,7 +568,7 @@ Does 'main' print "error 1" or "error no"?  We don't really want 'f'
 to unbox its second argument.  This actually happened in GHC's onwn
 source code, in Packages.applyPackageFlag, which ended up un-boxing
 the enormous DynFlags tuple, and being strict in the
-as-yet-un-filled-in pkgState files.
+as-yet-un-filled-in unitState files.
 -}

 ----------------------
@@ -998,23 +999,35 @@ deepSplitCprType_maybe _ _ _ = Nothing
 findTypeShape :: FamInstEnvs -> Type -> TypeShape
 -- Uncover the arrow and product shape of a type
 -- The data type TypeShape is defined in GHC.Types.Demand
-- See Note [Trimming a demand to a type] in GHC.Types.Demand
+-- See Note [Trimming a demand to a type] in GHC.Core.Opt.DmdAnal
 findTypeShape fam_envs ty
-  | Just (tc, tc_args)  <- splitTyConApp_maybe ty
-  , Just con <- isDataProductTyCon_maybe tc
-  = TsProd (map (findTypeShape fam_envs) $ dataConInstArgTys con tc_args)
-
-  | Just (_, res) <- splitFunTy_maybe ty
-  = TsFun (findTypeShape fam_envs res)
-
-  | Just (_, ty') <- splitForAllTy_maybe ty
-  = findTypeShape fam_envs ty'
-
-  | Just (_, ty') <- topNormaliseType_maybe fam_envs ty
-  = findTypeShape fam_envs ty'
-
-  | otherwise
-  = TsUnk
+  = go (setRecTcMaxBound 2 initRecTc) ty
+       -- You might think this bound of 2 is low, but actually
+       -- I think even 1 would be fine.  This only bites for recursive
+       -- product types, which are rare, and we really don't want
+       -- to look deep into such products -- see #18034
+  where
+    go rec_tc ty
+       | Just (_, res) <- splitFunTy_maybe ty
+       = TsFun (go rec_tc res)
+
+       | Just (tc, tc_args)  <- splitTyConApp_maybe ty
+       , Just con <- isDataProductTyCon_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) (dataConInstArgTys con tc_args))
+
+       | Just (_, ty') <- splitForAllTy_maybe ty
+       = go rec_tc ty'
+
+       | Just (_, ty') <- topNormaliseType_maybe fam_envs ty
+       = go rec_tc ty'
+
+       | otherwise
+       = TsUnk

 {-
 ************************************************************************

--- a/compiler/GHC/CoreToStg/Prep.hs
+++ b/compiler/GHC/CoreToStg/Prep.hs
@@ -1556,9 +1556,9 @@ lookupNaturalSDataConName dflags hsc_env = case integerLibrary dflags of
 -- | Helper for 'lookupMkIntegerName', 'lookupIntegerSDataConName'
 guardIntegerUse :: DynFlags -> IO a -> IO a
 guardIntegerUse dflags act
-  | thisPackage dflags == primUnitId
+  | homeUnitId dflags == primUnitId
  = return $ panic "Can't use Integer in ghc-prim"
-  | thisPackage dflags == integerUnitId
+  | homeUnitId dflags == integerUnitId
  = return $ panic "Can't use Integer in integer-*"
  | otherwise = act

@@ -1568,11 +1568,11 @@ guardIntegerUse dflags act
 -- literals in `base`. If we do, we get interface loading error for GHC.Natural.
 guardNaturalUse :: DynFlags -> IO a -> IO a
 guardNaturalUse dflags act
-  | thisPackage dflags == primUnitId
+  | homeUnitId dflags == primUnitId
  = return $ panic "Can't use Natural in ghc-prim"
-  | thisPackage dflags == integerUnitId
+  | homeUnitId dflags == integerUnitId
  = return $ panic "Can't use Natural in integer-*"
-  | thisPackage dflags == baseUnitId
+  | homeUnitId dflags == baseUnitId
  = return $ panic "Can't use Natural in base"
  | otherwise = act


--- a/compiler/GHC/Driver/Backpack.hs
+++ b/compiler/GHC/Driver/Backpack.hs
@@ -86,7 +86,7 @@ doBackpack [src_filename] = do
        POk _ pkgname_bkp -> do
            -- OK, so we have an LHsUnit PackageName, but we want an
            -- LHsUnit HsComponentId.  So let's rename it.
-            let pkgstate = pkgState dflags
+            let pkgstate = unitState dflags
            let bkp = renameHsUnits pkgstate (bkpPackageNameMap pkgstate pkgname_bkp) pkgname_bkp
            initBkpM src_filename bkp $
                forM_ (zip [1..] bkp) $ \(i, lunit) -> do
@@ -171,9 +171,12 @@ withBkpSession cid insts deps session_type do_this = do
        hscTarget   = case session_type of
                        TcSession -> HscNothing
                        _ -> hscTarget dflags,
-        thisUnitIdInsts_ = Just insts,
-        thisComponentId_ = Just cid,
-        thisUnitId =
+        homeUnitInstantiations = insts,
+                                 -- if we don't have any instantiation, don't
+                                 -- fill `homeUnitInstanceOfId` as it makes no
+                                 -- sense (we're not instantiating anything)
+        homeUnitInstanceOfId   = if null insts then Nothing else Just cid,
+        homeUnitId =
            case session_type of
                TcSession -> newUnitId cid Nothing
                -- No hash passed if no instances
@@ -191,7 +194,8 @@ withBkpSession cid insts deps session_type do_this = do
        importPaths = [],
        -- Synthesized the flags
        packageFlags = packageFlags dflags ++ map (\(uid0, rn) ->
-          let uid = unwireUnit dflags (improveUnit (unitInfoMap (pkgState dflags)) $ renameHoleUnit (pkgState dflags) (listToUFM insts) uid0)
+          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))
@@ -199,8 +203,7 @@ withBkpSession cid insts deps session_type do_this = do
      } )) $ do
        dflags <- getSessionDynFlags
        -- pprTrace "flags" (ppr insts <> ppr deps) $ return ()
-        -- Calls initPackages
-        _ <- setSessionDynFlags dflags
+        setSessionDynFlags dflags -- calls initUnits
        do_this

 withBkpExeSession :: [(Unit, ModRenaming)] -> BkpM a -> BkpM a
@@ -259,7 +262,7 @@ buildUnit session cid insts lunit = do
    -- 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 (pkgState dflags) hsubst) raw_deps
+        deps0 = map (renameHoleUnit (unitState dflags) 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
@@ -272,7 +275,7 @@ buildUnit session cid insts lunit = do

    dflags <- getDynFlags
    -- IMPROVE IT
-    let deps = map (improveUnit (unitInfoMap (pkgState dflags))) deps0
+    let deps = map (improveUnit (unitState dflags)) deps0

    mb_old_eps <- case session of
                    TcSession -> fmap Just getEpsGhc
@@ -302,6 +305,7 @@ buildUnit session cid insts lunit = do
                      $ home_mod_infos
            getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
            obj_files = concatMap getOfiles linkables
+            state     = unitState (hsc_dflags hsc_env)

        let compat_fs = unitIdFS (indefUnit cid)
            compat_pn = PackageName compat_fs
@@ -312,7 +316,7 @@ buildUnit session cid insts lunit = do
            unitPackageId = PackageId compat_fs,
            unitPackageName = compat_pn,
            unitPackageVersion = makeVersion [],
-            unitId = toUnitId (thisPackage dflags),
+            unitId = toUnitId (homeUnit dflags),
            unitComponentName = Nothing,
            unitInstanceOf = cid,
            unitInstantiations = insts,
@@ -326,7 +330,7 @@ buildUnit session cid insts lunit = do
                        -- really used for anything, so we leave it
                        -- blank for now.
                        TcSession -> []
-                        _ -> map (toUnitId . unwireUnit dflags)
+                        _ -> map (toUnitId . unwireUnit state)
                                $ deps ++ [ moduleUnit mod
                                          | (_, mod) <- insts
                                          , not (isHoleModule mod) ],
@@ -363,7 +367,7 @@ buildUnit session cid insts lunit = do

 compileExe :: LHsUnit HsComponentId -> BkpM ()
 compileExe lunit = do
-    msgUnitId mainUnitId
+    msgUnitId mainUnit
    let deps_w_rns = hsunitDeps False (unLoc lunit)
        deps = map fst deps_w_rns
        -- no renaming necessary
@@ -376,30 +380,29 @@ compileExe lunit = do
        ok <- load' LoadAllTargets (Just msg) mod_graph
        when (failed ok) (liftIO $ exitWith (ExitFailure 1))

-- | Register a new virtual package database containing a single unit
+-- | Register a new virtual unit database containing a single unit
 addPackage :: GhcMonad m => UnitInfo -> m ()
 addPackage pkg = do
    dflags <- GHC.getSessionDynFlags
-    case pkgDatabase dflags of
+    case unitDatabases dflags of
        Nothing -> panic "addPackage: called too early"
        Just dbs -> do
-         let newdb = PackageDatabase
-               { packageDatabasePath  = "(in memory " ++ showSDoc dflags (ppr (unitId pkg)) ++ ")"
-               , packageDatabaseUnits = [pkg]
+         let newdb = UnitDatabase
+               { unitDatabasePath  = "(in memory " ++ showSDoc dflags (ppr (unitId pkg)) ++ ")"
+               , unitDatabaseUnits = [pkg]
               }
-         _ <- GHC.setSessionDynFlags (dflags { pkgDatabase = Just (dbs ++ [newdb]) })
-         return ()
+         GHC.setSessionDynFlags (dflags { unitDatabases = Just (dbs ++ [newdb]) })

 compileInclude :: Int -> (Int, Unit) -> BkpM ()
 compileInclude n (i, uid) = do
    hsc_env <- getSession
-    let dflags = hsc_dflags hsc_env
+    let pkgs = unitState (hsc_dflags hsc_env)
    msgInclude (i, n) uid
    -- Check if we've compiled it already
    case uid of
      HoleUnit   -> return ()
      RealUnit _ -> return ()
-      VirtUnit i -> case lookupUnit dflags uid of
+      VirtUnit i -> case lookupUnit pkgs uid of
        Nothing -> innerBkpM $ compileUnit (instUnitInstanceOf i) (instUnitInsts i)
        Just _  -> return ()

@@ -557,14 +560,14 @@ type PackageNameMap a = Map PackageName a

 -- For now, something really simple, since we're not actually going
 -- to use this for anything
-unitDefines :: PackageState -> LHsUnit PackageName -> (PackageName, HsComponentId)
+unitDefines :: UnitState -> LHsUnit PackageName -> (PackageName, HsComponentId)
 unitDefines pkgstate (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) })
    = (pn, HsComponentId pn (mkIndefUnitId pkgstate fs))

-bkpPackageNameMap :: PackageState -> [LHsUnit PackageName] -> PackageNameMap HsComponentId
+bkpPackageNameMap :: UnitState -> [LHsUnit PackageName] -> PackageNameMap HsComponentId
 bkpPackageNameMap pkgstate units = Map.fromList (map (unitDefines pkgstate) units)

-renameHsUnits :: PackageState -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId]
+renameHsUnits :: UnitState -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId]
 renameHsUnits pkgstate m units = map (fmap renameHsUnit) units
  where

@@ -652,7 +655,7 @@ hsunitModuleGraph dflags unit = do
    --  requirement.
    let node_map = Map.fromList [ ((ms_mod_name n, ms_hsc_src n == HsigFile), n)
                                | n <- nodes ]
-    req_nodes <- fmap catMaybes . forM (thisUnitIdInsts dflags) $ \(mod_name, _) ->
+    req_nodes <- fmap catMaybes . forM (homeUnitInstantiations dflags) $ \(mod_name, _) ->
        let has_local = Map.member (mod_name, True) node_map
        in if has_local
            then return Nothing

--- a/compiler/GHC/Driver/CodeOutput.hs
+++ b/compiler/GHC/Driver/CodeOutput.hs
@@ -131,7 +131,7 @@ outputC dflags filenm cmm_stream packages
         --   * -#include options from the cmdline and OPTIONS pragmas
         --   * the _stub.h file, if there is one.
         --
-         let rts = unsafeGetUnitInfo dflags rtsUnitId
+         let rts = unsafeLookupUnitId (unitState dflags) rtsUnitId

         let cc_injects = unlines (map mk_include (unitIncludes rts))
             mk_include h_file =
@@ -223,7 +223,7 @@ outputForeignStubs dflags mod location stubs

        -- we need the #includes from the rts package for the stub files
        let rts_includes =
-               let rts_pkg = unsafeGetUnitInfo dflags rtsUnitId in
+               let rts_pkg = unsafeLookupUnitId (unitState dflags) rtsUnitId in
               concatMap mk_include (unitIncludes rts_pkg)
            mk_include i = "#include \"" ++ i ++ "\"\n"


--- a/compiler/GHC/Driver/Finder.hs
+++ b/compiler/GHC/Driver/Finder.hs
@@ -63,7 +63,7 @@ type BaseName = String  -- Basename of file
 -- source, interface, and object files for that module live.

 -- It does *not* know which particular package a module lives in.  Use
-- Packages.lookupModuleInAllPackages for that.
+-- Packages.lookupModuleInAllUnits for that.

 -- -----------------------------------------------------------------------------
 -- The finder's cache
@@ -74,7 +74,7 @@ flushFinderCaches :: HscEnv -> IO ()
 flushFinderCaches hsc_env =
  atomicModifyIORef' fc_ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ())
 where
-        this_pkg = thisPackage (hsc_dflags hsc_env)
+        this_pkg = homeUnit (hsc_dflags hsc_env)
        fc_ref = hsc_FC hsc_env
        is_ext mod _ | not (moduleUnit mod `unitIdEq` this_pkg) = True
                     | otherwise = False
@@ -135,7 +135,7 @@ findPluginModule hsc_env mod_name =
 findExactModule :: HscEnv -> InstalledModule -> IO InstalledFindResult
 findExactModule hsc_env mod =
    let dflags = hsc_dflags hsc_env
-    in if moduleUnit mod `unitIdEq` thisPackage dflags
+    in if moduleUnit mod `unitIdEq` homeUnit dflags
       then findInstalledHomeModule hsc_env (moduleName mod)
       else findPackageModule hsc_env mod

@@ -182,14 +182,14 @@ findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString
 findExposedPackageModule hsc_env mod_name mb_pkg
  = findLookupResult hsc_env
  $ lookupModuleWithSuggestions
-        (hsc_dflags hsc_env) mod_name mb_pkg
+        (unitState (hsc_dflags hsc_env)) mod_name mb_pkg

 findExposedPluginPackageModule :: HscEnv -> ModuleName
                               -> IO FindResult
 findExposedPluginPackageModule hsc_env mod_name
  = findLookupResult hsc_env
  $ lookupPluginModuleWithSuggestions
-        (hsc_dflags hsc_env) mod_name Nothing
+        (unitState (hsc_dflags hsc_env)) mod_name Nothing

 findLookupResult :: HscEnv -> LookupResult -> IO FindResult
 findLookupResult hsc_env r = case r of
@@ -226,12 +226,15 @@ findLookupResult hsc_env r = case r of
                          , fr_mods_hidden = []
                          , fr_unusables = unusables'
                          , fr_suggestions = [] })
-     LookupNotFound suggest ->
+     LookupNotFound suggest -> do
+       let suggest'
+             | gopt Opt_HelpfulErrors (hsc_dflags hsc_env) = suggest
+             | otherwise = []
       return (NotFound{ fr_paths = [], fr_pkg = Nothing
                       , fr_pkgs_hidden = []
                       , fr_mods_hidden = []
                       , fr_unusables = []
-                       , fr_suggestions = suggest })
+                       , fr_suggestions = suggest' })

 modLocationCache :: HscEnv -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult
 modLocationCache hsc_env mod do_this = do
@@ -245,7 +248,7 @@ modLocationCache hsc_env mod do_this = do

 mkHomeInstalledModule :: DynFlags -> ModuleName -> InstalledModule
 mkHomeInstalledModule dflags mod_name =
-  let iuid = thisUnitId dflags
+  let iuid = homeUnitId dflags
  in Module iuid mod_name

 -- This returns a module because it's more convenient for users
@@ -253,7 +256,7 @@ addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module
 addHomeModuleToFinder hsc_env mod_name loc = do
  let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name
  addToFinderCache (hsc_FC hsc_env) mod (InstalledFound loc mod)
-  return (mkModule (thisPackage (hsc_dflags hsc_env)) mod_name)
+  return (mkHomeModule (hsc_dflags hsc_env) mod_name)

 uncacheModule :: HscEnv -> ModuleName -> IO ()
 uncacheModule hsc_env mod_name = do
@@ -279,7 +282,7 @@ findHomeModule hsc_env mod_name = do
      }
 where
  dflags = hsc_dflags hsc_env
-  uid = thisPackage dflags
+  uid    = homeUnit dflags

 -- | Implements the search for a module name in the home package only.  Calling
 -- this function directly is usually *not* what you want; currently, it's used
@@ -340,9 +343,9 @@ findPackageModule hsc_env mod = do
  let
        dflags = hsc_dflags hsc_env
        pkg_id = moduleUnit mod
-        pkgstate = pkgState dflags
+        pkgstate = unitState dflags
  --
-  case lookupInstalledPackage pkgstate pkg_id of
+  case lookupUnitId pkgstate pkg_id of
     Nothing -> return (InstalledNoPackage pkg_id)
     Just pkg_conf -> findPackageModule_ hsc_env mod pkg_conf

@@ -669,6 +672,7 @@ cantFindErr cannot_find _ dflags mod_name find_result
  = ptext cannot_find <+> quotes (ppr mod_name)
    $$ more_info
  where
+    pkgs = unitState dflags
    more_info
      = case find_result of
            NoPackage pkg
@@ -678,7 +682,7 @@ cantFindErr cannot_find _ dflags mod_name find_result
            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, pkg /= thisPackage dflags
+                | Just pkg <- mb_pkg, pkg /= homeUnit dflags
                -> not_found_in_package pkg files

                | not (null suggest)
@@ -723,11 +727,11 @@ cantFindErr cannot_find _ dflags mod_name find_result
        <> dot $$ pkg_hidden_hint uid
    pkg_hidden_hint uid
     | gopt Opt_BuildingCabalPackage dflags
-        = let pkg = expectJust "pkg_hidden" (lookupUnit dflags uid)
+        = let pkg = expectJust "pkg_hidden" (lookupUnit pkgs uid)
           in text "Perhaps you need to add" <+>
              quotes (ppr (unitPackageName pkg)) <+>
              text "to the build-depends in your .cabal file."
-     | Just pkg <- lookupUnit dflags uid
+     | Just pkg <- lookupUnit pkgs uid
         = text "You can run" <+>
           quotes (text ":set -package " <> ppr (unitPackageName pkg)) <+>
           text "to expose it." $$
@@ -754,7 +758,7 @@ cantFindErr cannot_find _ dflags mod_name find_result
    pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o
      where provenance ModHidden = Outputable.empty
            provenance (ModUnusable _) = Outputable.empty
-            provenance (ModOrigin{ fromOrigPackage = e,
+            provenance (ModOrigin{ fromOrigUnit = e,
                                   fromExposedReexport = res,
                                   fromPackageFlag = f })
              | Just True <- e
@@ -771,7 +775,7 @@ cantFindErr cannot_find _ dflags mod_name find_result
    pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o
      where provenance ModHidden =  Outputable.empty
            provenance (ModUnusable _) = Outputable.empty
-            provenance (ModOrigin{ fromOrigPackage = e,
+            provenance (ModOrigin{ fromOrigUnit = e,
                                   fromHiddenReexport = rhs })
              | Just False <- e
                 = parens (text "needs flag -package-id"
@@ -794,7 +798,7 @@ cantFindInstalledErr cannot_find _ dflags mod_name find_result
                   text "was found" $$ looks_like_srcpkgid pkg

            InstalledNotFound files mb_pkg
-                | Just pkg <- mb_pkg, not (pkg `unitIdEq` thisPackage dflags)
+                | Just pkg <- mb_pkg, not (pkg `unitIdEq` homeUnit dflags)
                -> not_found_in_package pkg files

                | null files
@@ -806,7 +810,7 @@ cantFindInstalledErr cannot_find _ dflags mod_name find_result
            _ -> panic "cantFindInstalledErr"

    build_tag = buildTag dflags
-    pkgstate = pkgState dflags
+    pkgstate = unitState dflags

    looks_like_srcpkgid :: UnitId -> SDoc
    looks_like_srcpkgid pk

--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -470,12 +470,12 @@ hsc_typecheck keep_rn mod_summary mb_rdr_module = do
        dflags = hsc_dflags hsc_env
        outer_mod = ms_mod mod_summary
        mod_name = moduleName outer_mod
-        outer_mod' = mkModule (thisPackage dflags) mod_name
+        outer_mod' = mkHomeModule dflags mod_name
        inner_mod = canonicalizeHomeModule dflags mod_name
        src_filename  = ms_hspp_file mod_summary
        real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1
        keep_rn' = gopt Opt_WriteHie dflags || keep_rn
-    MASSERT( moduleUnit outer_mod == thisPackage dflags )
+    MASSERT( isHomeModule dflags outer_mod )
    tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod)
        then ioMsgMaybe $ tcRnInstantiateSignature hsc_env outer_mod' real_loc
        else
@@ -1116,8 +1116,8 @@ hscCheckSafe' m l = do
    dflags <- getDynFlags
    (tw, pkgs) <- isModSafe m l
    case tw of
-        False                     -> return (Nothing, pkgs)
-        True | isHomePkg dflags m -> return (Nothing, pkgs)
+        False                        -> return (Nothing, pkgs)
+        True | isHomeModule dflags m -> return (Nothing, pkgs)
             -- TODO: do we also have to check the trust of the instantiation?
             -- Not necessary if that is reflected in dependencies
             | otherwise   -> return (Just $ toUnitId (moduleUnit m), pkgs)
@@ -1159,21 +1159,22 @@ hscCheckSafe' m l = do
                    return (trust == Sf_Trustworthy, pkgRs)

                where
+                    state = unitState dflags
                    inferredImportWarn = unitBag
                        $ makeIntoWarning (Reason Opt_WarnInferredSafeImports)
-                        $ mkWarnMsg dflags l (pkgQual dflags)
+                        $ mkWarnMsg dflags l (pkgQual state)
                        $ sep
                            [ text "Importing Safe-Inferred module "
                                <> ppr (moduleName m)
                                <> text " from explicitly Safe module"
                            ]
-                    pkgTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $
+                    pkgTrustErr = unitBag $ mkErrMsg dflags l (pkgQual state) $
                        sep [ ppr (moduleName m)
                                <> text ": Can't be safely imported!"
                            , text "The package (" <> ppr (moduleUnit m)
                                <> text ") the module resides in isn't trusted."
                            ]
-                    modTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $
+                    modTrustErr = unitBag $ mkErrMsg dflags l (pkgQual state) $
                        sep [ ppr (moduleName m)
                                <> text ": Can't be safely imported!"
                            , text "The module itself isn't safe." ]
@@ -1191,8 +1192,8 @@ hscCheckSafe' m l = do
    packageTrusted _ Sf_Safe  False _ = True
    packageTrusted _ Sf_SafeInferred False _ = True
    packageTrusted dflags _ _ m
-        | isHomePkg dflags m = True
-        | otherwise = unitIsTrusted $ unsafeGetUnitInfo dflags (moduleUnit m)
+        | isHomeModule dflags m = True
+        | otherwise = unitIsTrusted $ unsafeLookupUnit (unitState dflags) (moduleUnit m)

    lookup' :: Module -> Hsc (Maybe ModIface)
    lookup' m = do
@@ -1210,21 +1211,17 @@ hscCheckSafe' m l = do
        return iface'


-    isHomePkg :: DynFlags -> Module -> Bool
-    isHomePkg dflags m
-        | thisPackage dflags == moduleUnit m = True
-        | otherwise                               = False
-
 -- | Check the list of packages are trusted.
 checkPkgTrust :: Set UnitId -> Hsc ()
 checkPkgTrust pkgs = do
    dflags <- getDynFlags
    let errors = S.foldr go [] pkgs
+        state  = unitState dflags
        go pkg acc
-            | unitIsTrusted $ getInstalledPackageDetails (pkgState dflags) pkg
+            | unitIsTrusted $ unsafeLookupUnitId state pkg
            = acc
            | otherwise
-            = (:acc) $ mkErrMsg dflags noSrcSpan (pkgQual dflags)
+            = (:acc) $ mkErrMsg dflags noSrcSpan (pkgQual state)
                     $ text "The package (" <> ppr pkg <> text ") is required" <>
                       text " to be trusted but it isn't!"
    case errors of
@@ -1493,7 +1490,7 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
        let -- Make up a module name to give the NCG. We can't pass bottom here
            -- lest we reproduce #11784.
            mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename
-            cmm_mod = mkModule (thisPackage dflags) mod_name
+            cmm_mod = mkHomeModule dflags mod_name

        -- Compile decls in Cmm files one decl at a time, to avoid re-ordering
        -- them in SRT analysis.
No results found