[Git][ghc/ghc][master] Parser: don't require the HomeUnitId
Marge Bot
gitlab at gitlab.haskell.org
Tue Oct 13 04:13:34 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
0a5f2918 by Sylvain Henry at 2020-10-13T00:13:28-04:00
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 changed files:
- compiler/GHC/Cmm/Lexer.x
- compiler/GHC/Cmm/Parser.y
- compiler/GHC/Cmm/Monad.hs → compiler/GHC/Cmm/Parser/Monad.hs
- compiler/GHC/Driver/Config.hs
- compiler/GHC/Parser/Lexer.x
- compiler/ghc.cabal.in
- utils/haddock
Changes:
=====================================
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
=====================================
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 () }
=====================================
compiler/GHC/Cmm/Monad.hs → 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))
=====================================
compiler/GHC/Driver/Config.hs
=====================================
@@ -32,7 +32,6 @@ initParserOpts =
mkParserOpts
<$> warningFlags
<*> extensionFlags
- <*> homeUnitId_
<*> safeImportsOn
<*> gopt Opt_Haddock
<*> gopt Opt_KeepRawTokenStream
=====================================
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
=====================================
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
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit 7b5972402afad755cd45aaad1a96aac509e9d5d2
+Subproject commit 6f16399e0320d0ef5e6c3dd0329ce7ed3715b6b2
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0a5f29185921cf2af908988ab3608602bcb40290
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0a5f29185921cf2af908988ab3608602bcb40290
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20201013/72a22654/attachment-0001.html>
More information about the ghc-commits
mailing list