summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Cmm/Lexer.x2
-rw-r--r--compiler/GHC/Cmm/Parser.y178
-rw-r--r--compiler/GHC/Cmm/Parser/Monad.hs (renamed from compiler/GHC/Cmm/Monad.hs)11
-rw-r--r--compiler/GHC/Driver/Config.hs1
-rw-r--r--compiler/GHC/Parser/Lexer.x17
-rw-r--r--compiler/ghc.cabal.in2
m---------utils/haddock0
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
View Lorry Controller Status