Parser: don't require the HomeUnitId

The HomeUnitId is only used by the Cmm parser and this one has access to
the DynFlags, so it can grab the UnitId of the HomeUnit from them.

Bump haddock submodule

7 files changed, 114 insertions, 97 deletions

diff --git a/compiler/GHC/Cmm/Lexer.x b/compiler/GHC/Cmm/Lexer.x
index 956107e61e..a8ceaff809 100644
--- a/compiler/GHC/Cmm/Lexer.x
+++ b/compiler/GHC/Cmm/Lexer.x
@@ -20,7 +20,7 @@ import GHC.Prelude
 import GHC.Cmm.Expr
 
 import GHC.Parser.Lexer
-import GHC.Cmm.Monad
+import GHC.Cmm.Parser.Monad
 import GHC.Types.SrcLoc
 import GHC.Types.Unique.FM
 import GHC.Data.StringBuffer
diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y
index 6bbbdc819b..5067e04e79 100644
--- a/compiler/GHC/Cmm/Parser.y
+++ b/compiler/GHC/Cmm/Parser.y
@@ -234,8 +234,8 @@ import GHC.Cmm.Info
 import GHC.Cmm.BlockId
 import GHC.Cmm.Lexer
 import GHC.Cmm.CLabel
-import GHC.Cmm.Monad hiding (getPlatform, getProfile, getPtrOpts)
-import qualified GHC.Cmm.Monad as PD
+import GHC.Cmm.Parser.Monad hiding (getPlatform, getProfile, getPtrOpts)
+import qualified GHC.Cmm.Parser.Monad as PD
 import GHC.Cmm.CallConv
 import GHC.Runtime.Heap.Layout
 import GHC.Parser.Lexer
@@ -385,9 +385,11 @@ cmmtop  :: { CmmParse () }
         | cmmdata                       { $1 }
         | decl                          { $1 }
         | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'
-                {% liftP . withHomeUnitId $ \pkg ->
-                   do lits <- sequence $6;
-                      staticClosure pkg $3 $5 (map getLit lits) }
+                {% do
+                      home_unit_id <- getHomeUnitId
+                      liftP $ pure $ do
+                        lits <- sequence $6;
+                        staticClosure home_unit_id $3 $5 (map getLit lits) }
 
 -- The only static closures in the RTS are dummy closures like
 -- stg_END_TSO_QUEUE_closure and stg_dummy_ret.  We don't need
@@ -406,8 +408,10 @@ cmmdata :: { CmmParse () }
 
 data_label :: { CmmParse CLabel }
     : NAME ':'
-                {% liftP . withHomeUnitId $ \pkg ->
-                   return (mkCmmDataLabel pkg (NeedExternDecl False) $1) }
+                {% do
+                   home_unit_id <- getHomeUnitId
+                   liftP $ pure $ do
+                     pure (mkCmmDataLabel home_unit_id (NeedExternDecl False) $1) }
 
 statics :: { [CmmParse [CmmStatic]] }
         : {- empty -}                   { [] }
@@ -464,103 +468,117 @@ maybe_body :: { CmmParse () }
 
 info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
         : NAME
-                {% liftP . withHomeUnitId $ \pkg ->
-                   do   newFunctionName $1 pkg
-                        return (mkCmmCodeLabel pkg $1, Nothing, []) }
+                {% do
+                     home_unit_id <- getHomeUnitId
+                     liftP $ pure $ do
+                       newFunctionName $1 home_unit_id
+                       return (mkCmmCodeLabel home_unit_id $1, Nothing, []) }
 
 
         | 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
                 -- ptrs, nptrs, closure type, description, type
-                {% liftP . withHomeUnitId $ \pkg ->
-                   do profile <- getProfile
-                      let prof = profilingInfo profile $11 $13
-                          rep  = mkRTSRep (fromIntegral $9) $
-                                   mkHeapRep profile False (fromIntegral $5)
-                                                   (fromIntegral $7) Thunk
-                              -- not really Thunk, but that makes the info table
-                              -- we want.
-                      return (mkCmmEntryLabel pkg $3,
-                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
-                                           , cit_rep = rep
-                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
-                              []) }
+                {% do
+                      home_unit_id <- getHomeUnitId
+                      liftP $ pure $ do
+                        profile <- getProfile
+                        let prof = profilingInfo profile $11 $13
+                            rep  = mkRTSRep (fromIntegral $9) $
+                                     mkHeapRep profile False (fromIntegral $5)
+                                                     (fromIntegral $7) Thunk
+                                -- not really Thunk, but that makes the info table
+                                -- we want.
+                        return (mkCmmEntryLabel home_unit_id $3,
+                                Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id $3
+                                             , cit_rep = rep
+                                             , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
+                                []) }
 
         | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
                 -- ptrs, nptrs, closure type, description, type, fun type
-                {% liftP . withHomeUnitId $ \pkg ->
-                   do profile <- getProfile
-                      let prof = profilingInfo profile $11 $13
-                          ty   = Fun 0 (ArgSpec (fromIntegral $15))
-                                -- Arity zero, arg_type $15
-                          rep = mkRTSRep (fromIntegral $9) $
-                                    mkHeapRep profile False (fromIntegral $5)
-                                                    (fromIntegral $7) ty
-                      return (mkCmmEntryLabel pkg $3,
-                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
-                                           , cit_rep = rep
-                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
-                              []) }
+                {% do
+                      home_unit_id <- getHomeUnitId
+                      liftP $ pure $ do
+                        profile <- getProfile
+                        let prof = profilingInfo profile $11 $13
+                            ty   = Fun 0 (ArgSpec (fromIntegral $15))
+                                  -- Arity zero, arg_type $15
+                            rep = mkRTSRep (fromIntegral $9) $
+                                      mkHeapRep profile False (fromIntegral $5)
+                                                      (fromIntegral $7) ty
+                        return (mkCmmEntryLabel home_unit_id $3,
+                                Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id $3
+                                             , cit_rep = rep
+                                             , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
+                                []) }
                 -- we leave most of the fields zero here.  This is only used
                 -- to generate the BCO info table in the RTS at the moment.
 
         | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
                 -- ptrs, nptrs, tag, closure type, description, type
-                {% liftP . withHomeUnitId $ \pkg ->
-                   do profile <- getProfile
-                      let prof = profilingInfo profile $13 $15
-                          ty  = Constr (fromIntegral $9)  -- Tag
-                                       (BS8.pack $13)
-                          rep = mkRTSRep (fromIntegral $11) $
-                                  mkHeapRep profile False (fromIntegral $5)
-                                                  (fromIntegral $7) ty
-                      return (mkCmmEntryLabel pkg $3,
-                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
-                                           , cit_rep = rep
-                                           , cit_prof = prof, cit_srt = Nothing,cit_clo = Nothing },
-                              []) }
+                {% do
+                      home_unit_id <- getHomeUnitId
+                      liftP $ pure $ do
+                        profile <- getProfile
+                        let prof = profilingInfo profile $13 $15
+                            ty  = Constr (fromIntegral $9)  -- Tag
+                                         (BS8.pack $13)
+                            rep = mkRTSRep (fromIntegral $11) $
+                                    mkHeapRep profile False (fromIntegral $5)
+                                                    (fromIntegral $7) ty
+                        return (mkCmmEntryLabel home_unit_id $3,
+                                Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id $3
+                                             , cit_rep = rep
+                                             , cit_prof = prof, cit_srt = Nothing,cit_clo = Nothing },
+                                []) }
 
                      -- If profiling is on, this string gets duplicated,
                      -- but that's the way the old code did it we can fix it some other time.
 
         | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
                 -- selector, closure type, description, type
-                {% liftP . withHomeUnitId $ \pkg ->
-                   do profile <- getProfile
-                      let prof = profilingInfo profile $9 $11
-                          ty  = ThunkSelector (fromIntegral $5)
-                          rep = mkRTSRep (fromIntegral $7) $
-                                   mkHeapRep profile False 0 0 ty
-                      return (mkCmmEntryLabel pkg $3,
-                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
-                                           , cit_rep = rep
-                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
-                              []) }
+                {% do
+                      home_unit_id <- getHomeUnitId
+                      liftP $ pure $ do
+                        profile <- getProfile
+                        let prof = profilingInfo profile $9 $11
+                            ty  = ThunkSelector (fromIntegral $5)
+                            rep = mkRTSRep (fromIntegral $7) $
+                                     mkHeapRep profile False 0 0 ty
+                        return (mkCmmEntryLabel home_unit_id $3,
+                                Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id $3
+                                             , cit_rep = rep
+                                             , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
+                                []) }
 
         | 'INFO_TABLE_RET' '(' NAME ',' INT ')'
                 -- closure type (no live regs)
-                {% liftP . withHomeUnitId $ \pkg ->
-                   do let prof = NoProfilingInfo
-                          rep  = mkRTSRep (fromIntegral $5) $ mkStackRep []
-                      return (mkCmmRetLabel pkg $3,
-                              Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3
-                                           , cit_rep = rep
-                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
-                              []) }
+                {% do
+                      home_unit_id <- getHomeUnitId
+                      liftP $ pure $ do
+                        let prof = NoProfilingInfo
+                            rep  = mkRTSRep (fromIntegral $5) $ mkStackRep []
+                        return (mkCmmRetLabel home_unit_id $3,
+                                Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel home_unit_id $3
+                                             , cit_rep = rep
+                                             , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
+                                []) }
 
         | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'
                 -- closure type, live regs
-                {% liftP . withHomeUnitId $ \pkg ->
-                   do platform <- getPlatform
-                      live <- sequence $7
-                      let prof = NoProfilingInfo
-                          -- drop one for the info pointer
-                          bitmap = mkLiveness platform (drop 1 live)
-                          rep  = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap
-                      return (mkCmmRetLabel pkg $3,
-                              Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3
-                                           , cit_rep = rep
-                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
-                              live) }
+                {% do
+                      home_unit_id <- getHomeUnitId
+                      liftP $ pure $ do
+                        platform <- getPlatform
+                        live <- sequence $7
+                        let prof = NoProfilingInfo
+                            -- drop one for the info pointer
+                            bitmap = mkLiveness platform (drop 1 live)
+                            rep  = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap
+                        return (mkCmmRetLabel home_unit_id $3,
+                                Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel home_unit_id $3
+                                             , cit_rep = rep
+                                             , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
+                                live) }
 
 body    :: { CmmParse () }
         : {- empty -}                   { return () }
diff --git a/compiler/GHC/Cmm/Monad.hs b/compiler/GHC/Cmm/Parser/Monad.hs
index 7cee74cd34..cbe89248c8 100644
--- a/compiler/GHC/Cmm/Monad.hs
+++ b/compiler/GHC/Cmm/Parser/Monad.hs
@@ -7,13 +7,14 @@
 -- The parser for C-- requires access to a lot more of the 'DynFlags',
 -- so 'PD' provides access to 'DynFlags' via a 'HasDynFlags' instance.
 -----------------------------------------------------------------------------
-module GHC.Cmm.Monad (
+module GHC.Cmm.Parser.Monad (
     PD(..)
   , liftP
   , failMsgPD
   , getProfile
   , getPlatform
   , getPtrOpts
+  , getHomeUnitId
   ) where
 
 import GHC.Prelude
@@ -28,6 +29,8 @@ import GHC.Driver.Session
 import GHC.Parser.Lexer
 import GHC.Parser.Errors
 import GHC.Types.SrcLoc
+import GHC.Unit.Types
+import GHC.Unit.Home
 
 newtype PD a = PD { unPD :: DynFlags -> PState -> ParseResult a }
 
@@ -73,3 +76,9 @@ getPtrOpts = do
       { po_profile     = profile
       , po_align_check = gopt Opt_AlignmentSanitisation dflags
       }
+
+-- | Return the UnitId of the home-unit. This is used to create labels.
+getHomeUnitId :: PD UnitId
+getHomeUnitId = do
+   dflags <- getDynFlags
+   pure (homeUnitId (mkHomeUnitFromFlags dflags))
diff --git a/compiler/GHC/Driver/Config.hs b/compiler/GHC/Driver/Config.hs
index 9cb566437b..6bd8988add 100644
--- a/compiler/GHC/Driver/Config.hs
+++ b/compiler/GHC/Driver/Config.hs
@@ -32,7 +32,6 @@ initParserOpts =
   mkParserOpts
     <$> warningFlags
     <*> extensionFlags
-    <*> homeUnitId_
     <*> safeImportsOn
     <*> gopt Opt_Haddock
     <*> gopt Opt_KeepRawTokenStream
diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x
index f1b6e4efc6..654db86651 100644
--- a/compiler/GHC/Parser/Lexer.x
+++ b/compiler/GHC/Parser/Lexer.x
@@ -55,7 +55,7 @@ module GHC.Parser.Lexer (
    P(..), ParseResult(..),
    allocateComments,
    MonadP(..),
-   getRealSrcLoc, getPState, withHomeUnitId,
+   getRealSrcLoc, getPState,
    failMsgP, failLocMsgP, srcParseFail,
    getErrorMessages, getMessages,
    popContext, pushModuleContext, setLastToken, setSrcLoc,
@@ -104,7 +104,6 @@ import GHC.Data.OrdList
 import GHC.Utils.Misc ( readRational, readHexRational )
 
 import GHC.Types.SrcLoc
-import GHC.Unit.Types
 import GHC.Types.Basic ( InlineSpec(..), RuleMatchInfo(..),
                          IntegralLit(..), FractionalLit(..),
                          SourceText(..) )
@@ -2210,10 +2209,8 @@ warnopt f options = f `EnumSet.member` pWarningFlags options
 -- | Parser options.
 --
 -- See 'mkParserOpts' to construct this.
-data ParserOpts = ParserOpts {
-    pWarningFlags   :: EnumSet WarningFlag
-  , pHomeUnitId     :: UnitId      -- ^ id of the unit currently being compiled
-                                   -- (only used in Cmm parser)
+data ParserOpts = ParserOpts
+  { pWarningFlags   :: EnumSet WarningFlag -- ^ enabled warning flags
   , pExtsBitmap     :: !ExtsBitmap -- ^ bitmap of permitted extensions
   }
 
@@ -2322,9 +2319,6 @@ failLocMsgP loc1 loc2 f =
 getPState :: P PState
 getPState = P $ \s -> POk s s
 
-withHomeUnitId :: (UnitId -> a) -> P a
-withHomeUnitId f = P $ \s@(PState{options = o}) -> POk s (f (pHomeUnitId o))
-
 getExts :: P ExtsBitmap
 getExts = P $ \s -> POk s (pExtsBitmap . options $ s)
 
@@ -2637,8 +2631,6 @@ data ExtBits
 mkParserOpts
   :: EnumSet WarningFlag        -- ^ warnings flags enabled
   -> EnumSet LangExt.Extension  -- ^ permitted language extensions enabled
-  -> UnitId                     -- ^ id of the unit currently being compiled
-                                -- (used in Cmm parser)
   -> Bool                       -- ^ are safe imports on?
   -> Bool                       -- ^ keeping Haddock comment tokens
   -> Bool                       -- ^ keep regular comment tokens
@@ -2650,11 +2642,10 @@ mkParserOpts
 
   -> ParserOpts
 -- ^ Given exactly the information needed, set up the 'ParserOpts'
-mkParserOpts warningFlags extensionFlags homeUnitId
+mkParserOpts warningFlags extensionFlags
   safeImports isHaddock rawTokStream usePosPrags =
     ParserOpts {
       pWarningFlags = warningFlags
-    , pHomeUnitId   = homeUnitId
     , pExtsBitmap   = safeHaskellBit .|. langExtBits .|. optBits
     }
   where
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 4efae27e97..c0f01db2ee 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -239,7 +239,7 @@ Library
         GHC.Cmm.Lint
         GHC.Cmm.Liveness
         GHC.Cmm.MachOp
-        GHC.Cmm.Monad
+        GHC.Cmm.Parser.Monad
         GHC.Cmm.Switch
         GHC.Cmm.Node
         GHC.Cmm.Opt
diff --git a/utils/haddock b/utils/haddock
-Subproject 7b5972402afad755cd45aaad1a96aac509e9d5d
+Subproject 6f16399e0320d0ef5e6c3dd0329ce7ed3715b6b