Move Unit related fields from DynFlags to HscEnv

The unit database cache, the home unit and the unit state were stored in
DynFlags while they ought to be stored in the compiler session state
(HscEnv). This patch fixes this.

It introduces a new UnitEnv type that should be used in the future to
handle separate unit environments (especially host vs target units).

Related to #17957

Bump haddock submodule

3 files changed, 14 insertions, 15 deletions

diff --git a/compiler/GHC/Cmm/Lexer.x b/compiler/GHC/Cmm/Lexer.x
index a8ceaff809..3828685645 100644
--- a/compiler/GHC/Cmm/Lexer.x
+++ b/compiler/GHC/Cmm/Lexer.x
@@ -362,8 +362,8 @@ alexGetByte (loc,s)
         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 } ()
 }
diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y
index 5067e04e79..b0a7465a48 100644
--- a/compiler/GHC/Cmm/Parser.y
+++ b/compiler/GHC/Cmm/Parser.y
@@ -244,6 +244,7 @@ import GHC.Parser.Errors
 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
@@ -1104,7 +1105,7 @@ isPtrGlobalReg (VanillaReg _ VGcPtr) = True
 isPtrGlobalReg _                     = False
 
 happyError :: PD a
-happyError = PD $ \_ s -> unP srcParseFail s
+happyError = PD $ \_ _ s -> unP srcParseFail s
 
 -- -----------------------------------------------------------------------------
 -- Statement-level macros
@@ -1447,8 +1448,8 @@ initEnv profile = listToUFM [
   ]
   where platform = profilePlatform profile
 
-parseCmmFile :: DynFlags -> FilePath -> IO (Bag Warning, Bag Error, Maybe CmmGroup)
-parseCmmFile dflags filename = do
+parseCmmFile :: DynFlags -> HomeUnit -> FilePath -> IO (Bag Warning, Bag Error, Maybe CmmGroup)
+parseCmmFile dflags home_unit filename = do
   buf <- hGetStringBuffer filename
   let
         init_loc = mkRealSrcLoc (mkFastString filename) 1 1
@@ -1456,7 +1457,7 @@ parseCmmFile dflags filename = do
         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)
diff --git a/compiler/GHC/Cmm/Parser/Monad.hs b/compiler/GHC/Cmm/Parser/Monad.hs
index cbe89248c8..b8aa0180d8 100644
--- a/compiler/GHC/Cmm/Parser/Monad.hs
+++ b/compiler/GHC/Cmm/Parser/Monad.hs
@@ -32,7 +32,7 @@ import GHC.Types.SrcLoc
 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,7 +45,7 @@ instance Monad PD where
   (>>=) = 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 = liftP . failMsgP
@@ -54,13 +54,13 @@ 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 @@ getPtrOpts = do
 
 -- | 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)