summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorVladislav Zavialov <vlad.z.4096@gmail.com>2021-04-06 15:51:38 +0300
committerMarge Bot <ben+marge-bot@smart-cactus.org>2021-05-23 18:53:13 -0400
commitd82d38239f232c3970a8641bb6d47d436e3cbc11 (patch)
tree55b162143144486cddda1b2a2a7ca0b7eb373a1c
parent82c6a9394b0457e77bc8b03e3594111b51508469 (diff)
downloadhaskell-d82d38239f232c3970a8641bb6d47d436e3cbc11.tar.gz
Introduce Strict.Maybe, Strict.Pair (#19156)
This patch fixes a space leak related to the use of Maybe in RealSrcSpan by introducing a strict variant of Maybe. In addition to that, it also introduces a strict pair and uses the newly introduced strict data types in a few other places (e.g. the lexer/parser state) to reduce allocations. Includes a regression test.
-rw-r--r--compiler/GHC/Data/Strict.hs67
-rw-r--r--compiler/GHC/HsToCore/Monad.hs3
-rw-r--r--compiler/GHC/Iface/Ext/Ast.hs3
-rw-r--r--compiler/GHC/Iface/Ext/Utils.hs3
-rw-r--r--compiler/GHC/Parser.y12
-rw-r--r--compiler/GHC/Parser/Annotation.hs3
-rw-r--r--compiler/GHC/Parser/Header.hs3
-rw-r--r--compiler/GHC/Parser/Lexer.x58
-rw-r--r--compiler/GHC/Parser/PostProcess.hs15
-rw-r--r--compiler/GHC/Parser/PostProcess/Haddock.hs20
-rw-r--r--compiler/GHC/Tc/Errors.hs5
-rw-r--r--compiler/GHC/Tc/Utils/Monad.hs3
-rw-r--r--compiler/GHC/Types/SrcLoc.hs25
-rw-r--r--compiler/GHC/Utils/Binary.hs10
-rw-r--r--compiler/ghc.cabal.in1
-rw-r--r--ghc/GHCi/UI.hs7
-rw-r--r--ghc/GHCi/UI/Info.hs3
-rw-r--r--testsuite/tests/ghc-api/T19156.hs7
-rw-r--r--testsuite/tests/ghc-api/all.T2
-rw-r--r--testsuite/tests/parser/should_run/CountAstDeps.stdout3
-rw-r--r--testsuite/tests/parser/should_run/CountParserDeps.stdout3
21 files changed, 178 insertions, 78 deletions
diff --git a/compiler/GHC/Data/Strict.hs b/compiler/GHC/Data/Strict.hs
new file mode 100644
index 0000000000..d028d51c64
--- /dev/null
+++ b/compiler/GHC/Data/Strict.hs
@@ -0,0 +1,67 @@
+-- Strict counterparts to common data structures,
+-- e.g. tuples, lists, maybes, etc.
+--
+-- Import this module qualified as Strict.
+
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveTraversable #-}
+
+module GHC.Data.Strict (
+ Maybe(Nothing, Just),
+ fromMaybe,
+ Pair(And),
+
+ -- Not used at the moment:
+ --
+ -- Either(Left, Right),
+ -- List(Nil, Cons),
+ ) where
+
+import GHC.Prelude hiding (Maybe(..), Either(..))
+import Control.Applicative
+import Data.Semigroup
+import Data.Data
+
+data Maybe a = Nothing | Just !a
+ deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Data)
+
+fromMaybe :: a -> Maybe a -> a
+fromMaybe d Nothing = d
+fromMaybe _ (Just x) = x
+
+apMaybe :: Maybe (a -> b) -> Maybe a -> Maybe b
+apMaybe (Just f) (Just x) = Just (f x)
+apMaybe _ _ = Nothing
+
+altMaybe :: Maybe a -> Maybe a -> Maybe a
+altMaybe Nothing r = r
+altMaybe l _ = l
+
+instance Semigroup a => Semigroup (Maybe a) where
+ Nothing <> b = b
+ a <> Nothing = a
+ Just a <> Just b = Just (a <> b)
+
+instance Semigroup a => Monoid (Maybe a) where
+ mempty = Nothing
+
+instance Applicative Maybe where
+ pure = Just
+ (<*>) = apMaybe
+
+instance Alternative Maybe where
+ empty = Nothing
+ (<|>) = altMaybe
+
+data Pair a b = !a `And` !b
+ deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Data)
+
+-- The definitions below are commented out because they are
+-- not used anywhere in the compiler, but are useful to showcase
+-- the intent behind this module (i.e. how it may evolve).
+--
+-- data Either a b = Left !a | Right !b
+-- deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Data)
+--
+-- data List a = Nil | !a `Cons` !(List a)
+-- deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Data)
diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs
index 691f78b4ef..6844606276 100644
--- a/compiler/GHC/HsToCore/Monad.hs
+++ b/compiler/GHC/HsToCore/Monad.hs
@@ -109,6 +109,7 @@ import GHC.Types.Error
import GHC.Utils.Error
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import qualified GHC.Data.Strict as Strict
import Data.IORef
@@ -454,7 +455,7 @@ updPmNablas nablas = updLclEnv (\env -> env { dsl_nablas = nablas })
getSrcSpanDs :: DsM SrcSpan
getSrcSpanDs = do { env <- getLclEnv
- ; return (RealSrcSpan (dsl_loc env) Nothing) }
+ ; return (RealSrcSpan (dsl_loc env) Strict.Nothing) }
putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
putSrcSpanDs (UnhelpfulSpan {}) thing_inside
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index bbfd7294c5..c9cbd4b723 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -59,6 +59,7 @@ import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
import GHC.Data.Maybe
import GHC.Data.FastString
+import qualified GHC.Data.Strict as Strict
import GHC.Iface.Ext.Types
import GHC.Iface.Ext.Utils
@@ -352,7 +353,7 @@ enrichHie ts (hsGrp, imports, exports, _) ev_bs insts tcs =
top_ev_asts :: [HieAST Type] <- do
let
l :: SrcSpanAnnA
- l = noAnnSrcSpan (RealSrcSpan (realSrcLocSpan $ mkRealSrcLoc file 1 1) Nothing)
+ l = noAnnSrcSpan (RealSrcSpan (realSrcLocSpan $ mkRealSrcLoc file 1 1) Strict.Nothing)
toHie $ EvBindContext ModuleScope Nothing
$ L l (EvBinds ev_bs)
diff --git a/compiler/GHC/Iface/Ext/Utils.hs b/compiler/GHC/Iface/Ext/Utils.hs
index 0a9150f532..37252c43bc 100644
--- a/compiler/GHC/Iface/Ext/Utils.hs
+++ b/compiler/GHC/Iface/Ext/Utils.hs
@@ -26,6 +26,7 @@ import GHC.Core.Type
import GHC.Types.Var
import GHC.Types.Var.Env
import GHC.Parser.Annotation
+import qualified GHC.Data.Strict as Strict
import GHC.Iface.Ext.Types
@@ -546,7 +547,7 @@ combineScopes _ ModuleScope = ModuleScope
combineScopes NoScope x = x
combineScopes x NoScope = x
combineScopes (LocalScope a) (LocalScope b) =
- mkScope $ combineSrcSpans (RealSrcSpan a Nothing) (RealSrcSpan b Nothing)
+ mkScope $ combineSrcSpans (RealSrcSpan a Strict.Nothing) (RealSrcSpan b Strict.Nothing)
mkSourcedNodeInfo :: NodeOrigin -> NodeInfo a -> SourcedNodeInfo a
mkSourcedNodeInfo org ni = SourcedNodeInfo $ M.singleton org ni
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 17a95f6857..1848b6b1df 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -64,6 +64,7 @@ import GHC.Utils.Outputable
import GHC.Utils.Misc ( looksLikePackageName, fstOf3, sndOf3, thdOf3 )
import GHC.Utils.Panic
import GHC.Prelude
+import qualified GHC.Data.Strict as Strict
import GHC.Types.Name.Reader
import GHC.Types.Name.Occurrence ( varName, dataName, tcClsName, tvName, occNameFS, mkVarOcc, occNameString)
@@ -4091,9 +4092,9 @@ looksLikeMult :: LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> Bool
looksLikeMult ty1 l_op ty2
| Unqual op_name <- unLoc l_op
, occNameFS op_name == fsLit "%"
- , Just ty1_pos <- getBufSpan (getLocA ty1)
- , Just pct_pos <- getBufSpan (getLocA l_op)
- , Just ty2_pos <- getBufSpan (getLocA ty2)
+ , Strict.Just ty1_pos <- getBufSpan (getLocA ty1)
+ , Strict.Just pct_pos <- getBufSpan (getLocA l_op)
+ , Strict.Just ty2_pos <- getBufSpan (getLocA ty2)
, bufSpanEnd ty1_pos /= bufSpanStart pct_pos
, bufSpanEnd pct_pos == bufSpanStart ty2_pos
= True
@@ -4230,8 +4231,9 @@ acsFinal a = do
csf <- getFinalCommentsFor l
meof <- getEofPos
let ce = case meof of
- Nothing -> EpaComments []
- Just (pos, gap) -> EpaCommentsBalanced [] [L (realSpanAsAnchor pos) (EpaComment EpaEofComment gap)]
+ Strict.Nothing -> EpaComments []
+ Strict.Just (pos `Strict.And` gap) ->
+ EpaCommentsBalanced [] [L (realSpanAsAnchor pos) (EpaComment EpaEofComment gap)]
return (a (cs Semi.<> csf Semi.<> ce))
acsa :: MonadP m => (EpAnnComments -> LocatedAn t a) -> m (LocatedAn t a)
diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs
index 20ac4bde62..abece56898 100644
--- a/compiler/GHC/Parser/Annotation.hs
+++ b/compiler/GHC/Parser/Annotation.hs
@@ -95,6 +95,7 @@ import GHC.Types.SrcLoc
import GHC.Utils.Binary
import GHC.Utils.Outputable hiding ( (<>) )
import GHC.Utils.Panic
+import qualified GHC.Data.Strict as Strict
{-
Note [exact print annotations]
@@ -928,7 +929,7 @@ widenSpan :: SrcSpan -> [AddEpAnn] -> SrcSpan
widenSpan s as = foldl combineSrcSpans s (go as)
where
go [] = []
- go (AddEpAnn _ (EpaSpan s):rest) = RealSrcSpan s Nothing : go rest
+ go (AddEpAnn _ (EpaSpan s):rest) = RealSrcSpan s Strict.Nothing : go rest
go (AddEpAnn _ (EpaDelta _):rest) = go rest
-- | The annotations need to all come after the anchor. Make sure
diff --git a/compiler/GHC/Parser/Header.hs b/compiler/GHC/Parser/Header.hs
index 7a60830d34..52a98d86dc 100644
--- a/compiler/GHC/Parser/Header.hs
+++ b/compiler/GHC/Parser/Header.hs
@@ -55,6 +55,7 @@ import GHC.Data.StringBuffer
import GHC.Data.Maybe
import GHC.Data.Bag (Bag, isEmptyBag )
import GHC.Data.FastString
+import qualified GHC.Data.Strict as Strict
import Control.Monad
import System.IO
@@ -347,7 +348,7 @@ toArgs starting_loc orig_str
advance_src_loc_many = foldl' advanceSrcLoc
locate :: RealSrcLoc -> RealSrcLoc -> a -> Located a
- locate begin end x = L (RealSrcSpan (mkRealSrcSpan begin end) Nothing) x
+ locate begin end x = L (RealSrcSpan (mkRealSrcSpan begin end) Strict.Nothing) x
toArgs' :: RealSrcLoc -> String -> Either String [Located String]
-- Remove outer quotes:
diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x
index dc13d44493..f9494afa6a 100644
--- a/compiler/GHC/Parser/Lexer.x
+++ b/compiler/GHC/Parser/Lexer.x
@@ -78,9 +78,11 @@ module GHC.Parser.Lexer (
) where
import GHC.Prelude
+import qualified GHC.Data.Strict as Strict
-- base
import Control.Monad
+import Control.Applicative
import Data.Char
import Data.List (stripPrefix, isInfixOf, partition)
import Data.Maybe
@@ -1581,7 +1583,7 @@ varid span buf len =
Just (ITcase, _) -> do
lastTk <- getLastTk
keyword <- case lastTk of
- Just (L _ ITlam) -> do
+ Strict.Just (L _ ITlam) -> do
lambdaCase <- getBit LambdaCaseBit
unless lambdaCase $ do
pState <- getPState
@@ -2256,7 +2258,7 @@ warnTab srcspan _buf _len = do
warnThen :: WarningFlag -> (SrcSpan -> PsWarning) -> Action -> Action
warnThen flag warning action srcspan buf len = do
- addWarning flag (warning (RealSrcSpan (psRealSpan srcspan) Nothing))
+ addWarning flag (warning (RealSrcSpan (psRealSpan srcspan) Strict.Nothing))
action srcspan buf len
-- -----------------------------------------------------------------------------
@@ -2324,9 +2326,10 @@ data PState = PState {
options :: ParserOpts,
warnings :: Bag PsWarning,
errors :: Bag PsError,
- tab_first :: Maybe RealSrcSpan, -- pos of first tab warning in the file
+ tab_first :: Strict.Maybe RealSrcSpan,
+ -- pos of first tab warning in the file
tab_count :: !Word, -- number of tab warnings in the file
- last_tk :: Maybe (PsLocated Token), -- last non-comment token
+ last_tk :: Strict.Maybe (PsLocated Token), -- last non-comment token
prev_loc :: PsSpan, -- pos of previous token, including comments,
prev_loc2 :: PsSpan, -- pos of two back token, including comments,
-- see Note [PsSpan in Comments]
@@ -2359,8 +2362,8 @@ data PState = PState {
-- locations of 'noise' tokens in the source, so that users of
-- the GHC API can do source to source conversions.
-- See note [exact print annotations] in GHC.Parser.Annotation
- eof_pos :: Maybe (RealSrcSpan, RealSrcSpan), -- pos, gap to prior token
- header_comments :: Maybe [LEpaComment],
+ eof_pos :: Strict.Maybe (Strict.Pair RealSrcSpan RealSrcSpan), -- pos, gap to prior token
+ header_comments :: Strict.Maybe [LEpaComment],
comment_q :: [LEpaComment],
-- Haddock comments accumulated in ascending order of their location
@@ -2418,7 +2421,7 @@ failMsgP f = do
failLocMsgP :: RealSrcLoc -> RealSrcLoc -> (SrcSpan -> PsError) -> P a
failLocMsgP loc1 loc2 f =
- addFatalError (f (RealSrcSpan (mkRealSrcSpan loc1 loc2) Nothing))
+ addFatalError (f (RealSrcSpan (mkRealSrcSpan loc1 loc2) Strict.Nothing))
getPState :: P PState
getPState = P $ \s -> POk s s
@@ -2448,7 +2451,7 @@ addSrcFile :: FastString -> P ()
addSrcFile f = P $ \s -> POk s{ srcfiles = f : srcfiles s } ()
setEofPos :: RealSrcSpan -> RealSrcSpan -> P ()
-setEofPos span gap = P $ \s -> POk s{ eof_pos = Just (span, gap) } ()
+setEofPos span gap = P $ \s -> POk s{ eof_pos = Strict.Just (span `Strict.And` gap) } ()
setLastToken :: PsSpan -> Int -> P ()
setLastToken loc len = P $ \s -> POk s {
@@ -2457,7 +2460,7 @@ setLastToken loc len = P $ \s -> POk s {
} ()
setLastTk :: PsLocated Token -> P ()
-setLastTk tk@(L l _) = P $ \s -> POk s { last_tk = Just tk
+setLastTk tk@(L l _) = P $ \s -> POk s { last_tk = Strict.Just tk
, prev_loc = l
, prev_loc2 = prev_loc s} ()
@@ -2465,7 +2468,7 @@ setLastComment :: PsLocated Token -> P ()
setLastComment (L l _) = P $ \s -> POk s { prev_loc = l
, prev_loc2 = prev_loc s} ()
-getLastTk :: P (Maybe (PsLocated Token))
+getLastTk :: P (Strict.Maybe (PsLocated Token))
getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk
-- see Note [PsSpan in Comments]
@@ -2844,9 +2847,9 @@ initParserState options buf loc =
options = options,
errors = emptyBag,
warnings = emptyBag,
- tab_first = Nothing,
+ tab_first = Strict.Nothing,
tab_count = 0,
- last_tk = Nothing,
+ last_tk = Strict.Nothing,
prev_loc = mkPsSpan init_loc init_loc,
prev_loc2 = mkPsSpan init_loc init_loc,
last_loc = mkPsSpan init_loc init_loc,
@@ -2861,8 +2864,8 @@ initParserState options buf loc =
alr_context = [],
alr_expecting_ocurly = Nothing,
alr_justClosedExplicitLetBlock = False,
- eof_pos = Nothing,
- header_comments = Nothing,
+ eof_pos = Strict.Nothing,
+ header_comments = Strict.Nothing,
comment_q = [],
hdk_comments = nilOL
}
@@ -2944,7 +2947,7 @@ instance MonadP P where
POk s {
header_comments = header_comments',
comment_q = comment_q'
- } (EpaCommentsBalanced (fromMaybe [] header_comments') (reverse newAnns))
+ } (EpaCommentsBalanced (Strict.fromMaybe [] header_comments') (reverse newAnns))
getCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments
getCommentsFor (RealSrcSpan l _) = allocateCommentsP l
@@ -2958,13 +2961,13 @@ getFinalCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments
getFinalCommentsFor (RealSrcSpan l _) = allocateFinalCommentsP l
getFinalCommentsFor _ = return emptyComments
-getEofPos :: P (Maybe (RealSrcSpan, RealSrcSpan))
+getEofPos :: P (Strict.Maybe (Strict.Pair RealSrcSpan RealSrcSpan))
getEofPos = P $ \s@(PState { eof_pos = pos }) -> POk s pos
addTabWarning :: RealSrcSpan -> P ()
addTabWarning srcspan
= P $ \s@PState{tab_first=tf, tab_count=tc, options=o} ->
- let tf' = if isJust tf then tf else Just srcspan
+ let tf' = tf <|> Strict.Just srcspan
tc' = tc + 1
s' = if warnopt Opt_WarnTabs o
then s{tab_first = tf', tab_count = tc'}
@@ -2984,8 +2987,9 @@ getMessages p =
-- we add the tabulation warning on the fly because
-- we count the number of occurrences of tab characters
ws' = case tab_first p of
- Nothing -> ws
- Just tf -> PsWarnTab (RealSrcSpan tf Nothing) (tab_count p)
+ Strict.Nothing -> ws
+ Strict.Just tf ->
+ PsWarnTab (RealSrcSpan tf Strict.Nothing) (tab_count p)
`consBag` ws
in (ws', errors p)
@@ -3482,8 +3486,8 @@ allocateComments ss comment_q =
allocatePriorComments
:: RealSrcSpan
-> [LEpaComment]
- -> Maybe [LEpaComment]
- -> (Maybe [LEpaComment], [LEpaComment], [LEpaComment])
+ -> Strict.Maybe [LEpaComment]
+ -> (Strict.Maybe [LEpaComment], [LEpaComment], [LEpaComment])
allocatePriorComments ss comment_q mheader_comments =
let
cmp (L l _) = anchor l <= ss
@@ -3492,14 +3496,14 @@ allocatePriorComments ss comment_q mheader_comments =
comment_q'= after
in
case mheader_comments of
- Nothing -> (Just newAnns, comment_q', [])
- Just _ -> (mheader_comments, comment_q', newAnns)
+ Strict.Nothing -> (Strict.Just newAnns, comment_q', [])
+ Strict.Just _ -> (mheader_comments, comment_q', newAnns)
allocateFinalComments
:: RealSrcSpan
-> [LEpaComment]
- -> Maybe [LEpaComment]
- -> (Maybe [LEpaComment], [LEpaComment], [LEpaComment])
+ -> Strict.Maybe [LEpaComment]
+ -> (Strict.Maybe [LEpaComment], [LEpaComment], [LEpaComment])
allocateFinalComments ss comment_q mheader_comments =
let
cmp (L l _) = anchor l <= ss
@@ -3508,8 +3512,8 @@ allocateFinalComments ss comment_q mheader_comments =
comment_q'= before
in
case mheader_comments of
- Nothing -> (Just newAnns, [], comment_q')
- Just _ -> (mheader_comments, [], comment_q' ++ newAnns)
+ Strict.Nothing -> (Strict.Just newAnns, [], comment_q')
+ Strict.Just _ -> (mheader_comments, [], comment_q' ++ newAnns)
commentToAnnotation :: RealLocated Token -> LEpaComment
commentToAnnotation (L l (ITdocCommentNext s ll)) = mkLEpaComment l ll (EpaDocCommentNext s)
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index d6b36b9d51..8cd5105e42 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -147,6 +147,7 @@ import qualified Data.Semigroup as Semi
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import qualified GHC.LanguageExtensions as LangExt
+import qualified GHC.Data.Strict as Strict
import Control.Monad
import Text.ParserCombinators.ReadP as ReadP
@@ -963,13 +964,13 @@ checkTyClHdr is_cls ty
lr = combineRealSrcSpans (realSrcSpan l) (anchor as)
-- lr = widenAnchorR as (realSrcSpan l)
an = (EpAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (EpaSpan $ realSrcSpan l) c []) cs)
- in SrcSpanAnn an (RealSrcSpan lr Nothing)
+ in SrcSpanAnn an (RealSrcSpan lr Strict.Nothing)
newAnns _ EpAnnNotUsed = panic "missing AnnParen"
newAnns (SrcSpanAnn (EpAnn ap (AnnListItem ta) csp) l) (EpAnn as (AnnParen _ o c) cs) =
let
lr = combineRealSrcSpans (anchor ap) (anchor as)
an = (EpAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (EpaSpan $ realSrcSpan l) c ta) (csp Semi.<> cs))
- in SrcSpanAnn an (RealSrcSpan lr Nothing)
+ in SrcSpanAnn an (RealSrcSpan lr Strict.Nothing)
-- | Yield a parse error if we have a function applied directly to a do block
-- etc. and BlockArguments is not enabled.
@@ -1053,18 +1054,18 @@ checkImportDecl mPre mPost = do
-- 'ImportQualifiedPost' is not in effect.
whenJust mPost $ \post ->
when (not importQualifiedPostEnabled) $
- failOpNotEnabledImportQualifiedPost (RealSrcSpan (epaLocationRealSrcSpan post) Nothing)
+ failOpNotEnabledImportQualifiedPost (RealSrcSpan (epaLocationRealSrcSpan post) Strict.Nothing)
-- Error if 'qualified' occurs in both pre and postpositive
-- positions.
whenJust mPost $ \post ->
when (isJust mPre) $
- failOpImportQualifiedTwice (RealSrcSpan (epaLocationRealSrcSpan post) Nothing)
+ failOpImportQualifiedTwice (RealSrcSpan (epaLocationRealSrcSpan post) Strict.Nothing)
-- Warn if 'qualified' found in prepositive position and
-- 'Opt_WarnPrepositiveQualifiedModule' is enabled.
whenJust mPre $ \pre ->
- warnPrepositiveQualifiedModule (RealSrcSpan (epaLocationRealSrcSpan pre) Nothing)
+ warnPrepositiveQualifiedModule (RealSrcSpan (epaLocationRealSrcSpan pre) Strict.Nothing)
-- -------------------------------------------------------------------------
-- Checking Patterns.
@@ -2727,7 +2728,7 @@ data PV_Accum =
PV_Accum
{ pv_warnings :: Bag PsWarning
, pv_errors :: Bag PsError
- , pv_header_comments :: Maybe [LEpaComment]
+ , pv_header_comments :: Strict.Maybe [LEpaComment]
, pv_comment_q :: [LEpaComment]
}
@@ -2831,7 +2832,7 @@ instance MonadP PV where
PV_Ok s {
pv_header_comments = header_comments',
pv_comment_q = comment_q'
- } (EpaCommentsBalanced (fromMaybe [] header_comments') (reverse newAnns))
+ } (EpaCommentsBalanced (Strict.fromMaybe [] header_comments') (reverse newAnns))
{- Note [Parser-Validator Hint]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/Parser/PostProcess/Haddock.hs b/compiler/GHC/Parser/PostProcess/Haddock.hs
index 189ddce29c..301e902f8b 100644
--- a/compiler/GHC/Parser/PostProcess/Haddock.hs
+++ b/compiler/GHC/Parser/PostProcess/Haddock.hs
@@ -73,6 +73,7 @@ import qualified Data.Monoid
import GHC.Parser.Lexer
import GHC.Parser.Errors
import GHC.Utils.Misc (mergeListsBy, filterOut, mapLastM, (<&&>))
+import qualified GHC.Data.Strict as Strict
{- Note [Adding Haddock comments to the syntax tree]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1023,7 +1024,8 @@ instance HasHaddock (LocatedA (HsType GhcPs)) where
-- which it is used.
data HdkA a =
HdkA
- !(Maybe BufSpan) -- Just b <=> BufSpan occupied by the processed AST element.
+ !(Strict.Maybe BufSpan)
+ -- Just b <=> BufSpan occupied by the processed AST element.
-- The surrounding computations will not look inside.
--
-- Nothing <=> No BufSpan (e.g. when the HdkA is constructed by 'pure' or 'liftHdkA').
@@ -1056,9 +1058,9 @@ instance Applicative HdkA where
-- These delim1/delim2 are key to how HdkA operates.
where
-- Delimit the LHS by the location information from the RHS
- delim1 = inLocRange (locRangeTo (fmap @Maybe bufSpanStart l2))
+ delim1 = inLocRange (locRangeTo (fmap @Strict.Maybe bufSpanStart l2))
-- Delimit the RHS by the location information from the LHS
- delim2 = inLocRange (locRangeFrom (fmap @Maybe bufSpanEnd l1))
+ delim2 = inLocRange (locRangeFrom (fmap @Strict.Maybe bufSpanEnd l1))
pure a =
-- Return a value without performing any stateful computation, and without
@@ -1377,14 +1379,14 @@ instance Monoid LocRange where
mempty = LocRange mempty mempty mempty
-- The location range from the specified position to the end of the file.
-locRangeFrom :: Maybe BufPos -> LocRange
-locRangeFrom (Just l) = mempty { loc_range_from = StartLoc l }
-locRangeFrom Nothing = mempty
+locRangeFrom :: Strict.Maybe BufPos -> LocRange
+locRangeFrom (Strict.Just l) = mempty { loc_range_from = StartLoc l }
+locRangeFrom Strict.Nothing = mempty
-- The location range from the start of the file to the specified position.
-locRangeTo :: Maybe BufPos -> LocRange
-locRangeTo (Just l) = mempty { loc_range_to = EndLoc l }
-locRangeTo Nothing = mempty
+locRangeTo :: Strict.Maybe BufPos -> LocRange
+locRangeTo (Strict.Just l) = mempty { loc_range_to = EndLoc l }
+locRangeTo Strict.Nothing = mempty
-- Represents a predicate on BufPos:
--
diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs
index dcd9745758..3a77998c8f 100644
--- a/compiler/GHC/Tc/Errors.hs
+++ b/compiler/GHC/Tc/Errors.hs
@@ -66,6 +66,7 @@ import GHC.Data.List.SetOps ( equivClasses )
import GHC.Data.Maybe
import qualified GHC.LanguageExtensions as LangExt
import GHC.Utils.FV ( fvVarList, unionFV )
+import qualified GHC.Data.Strict as Strict
import Control.Monad ( unless, when, foldM, forM_ )
import Data.Foldable ( toList )
@@ -1033,7 +1034,7 @@ mkErrorReport :: DiagnosticReason
mkErrorReport rea ctxt tcl_env (Report important relevant_bindings valid_subs)
= do { context <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)
; mkTcRnMessage rea
- (RealSrcSpan (tcl_loc tcl_env) Nothing)
+ (RealSrcSpan (tcl_loc tcl_env) Strict.Nothing)
(vcat important)
context
(vcat $ relevant_bindings ++ valid_subs)
@@ -1045,7 +1046,7 @@ mkErrorReportNC :: DiagnosticReason
-> Report
-> TcM (MsgEnvelope TcRnMessage)
mkErrorReportNC rea tcl_env (Report important relevant_bindings valid_subs)
- = mkTcRnMessage rea (RealSrcSpan (tcl_loc tcl_env) Nothing)
+ = mkTcRnMessage rea (RealSrcSpan (tcl_loc tcl_env) Strict.Nothing)
(vcat important)
O.empty
(vcat $ relevant_bindings ++ valid_subs)
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index 2d9298e12b..e385322223 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -188,6 +188,7 @@ import GHC.Utils.Panic
import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Misc
import GHC.Utils.Logger
+import qualified GHC.Data.Strict as Strict
import GHC.Types.Error
import GHC.Types.Fixity.Env
@@ -896,7 +897,7 @@ addDependentFiles fs = do
getSrcSpanM :: TcRn SrcSpan
-- Avoid clash with Name.getSrcLoc
-getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env) Nothing) }
+getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env) Strict.Nothing) }
-- See Note [Error contexts in generated code]
inGeneratedCode :: TcRn Bool
diff --git a/compiler/GHC/Types/SrcLoc.hs b/compiler/GHC/Types/SrcLoc.hs
index f90f6df109..6a2bc2c814 100644
--- a/compiler/GHC/Types/SrcLoc.hs
+++ b/compiler/GHC/Types/SrcLoc.hs
@@ -120,6 +120,7 @@ import GHC.Utils.Json
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Data.FastString
+import qualified GHC.Data.Strict as Strict
import Control.DeepSeq
import Control.Applicative (liftA2)
@@ -225,8 +226,8 @@ newtype BufPos = BufPos { bufPos :: Int }
-- | Source Location
data SrcLoc
- = RealSrcLoc !RealSrcLoc !(Maybe BufPos) -- See Note [Why Maybe BufPos]
- | UnhelpfulLoc FastString -- Just a general indication
+ = RealSrcLoc !RealSrcLoc !(Strict.Maybe BufPos) -- See Note [Why Maybe BufPos]
+ | UnhelpfulLoc !FastString -- Just a general indication
deriving (Eq, Show)
{-
@@ -238,14 +239,14 @@ data SrcLoc
-}
mkSrcLoc :: FastString -> Int -> Int -> SrcLoc
-mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col) Nothing
+mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col) Strict.Nothing
mkRealSrcLoc :: FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc x line col = SrcLoc (LexicalFastString x) line col
-getBufPos :: SrcLoc -> Maybe BufPos
+getBufPos :: SrcLoc -> Strict.Maybe BufPos
getBufPos (RealSrcLoc _ mbpos) = mbpos
-getBufPos (UnhelpfulLoc _) = Nothing
+getBufPos (UnhelpfulLoc _) = Strict.Nothing
-- | Built-in "bad" 'SrcLoc' values for particular locations
noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc
@@ -381,7 +382,7 @@ instance Semigroup BufSpan where
-- A 'SrcSpan' identifies either a specific portion of a text file
-- or a human-readable description of a location.
data SrcSpan =
- RealSrcSpan !RealSrcSpan !(Maybe BufSpan) -- See Note [Why Maybe BufPos]
+ RealSrcSpan !RealSrcSpan !(Strict.Maybe BufSpan) -- See Note [Why Maybe BufPos]
| UnhelpfulSpan !UnhelpfulSpanReason
deriving (Eq, Show) -- Show is used by GHC.Parser.Lexer, because we
@@ -430,9 +431,9 @@ instance ToJson RealSrcSpan where
instance NFData SrcSpan where
rnf x = x `seq` ()
-getBufSpan :: SrcSpan -> Maybe BufSpan
+getBufSpan :: SrcSpan -> Strict.Maybe BufSpan
getBufSpan (RealSrcSpan _ mbspan) = mbspan
-getBufSpan (UnhelpfulSpan _) = Nothing
+getBufSpan (UnhelpfulSpan _) = Strict.Nothing
-- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty
noSrcSpan, generatedSrcSpan, wiredInSrcSpan, interactiveSrcSpan :: SrcSpan
@@ -773,8 +774,8 @@ cmpLocated a b = unLoc a `compare` unLoc b
-- Precondition: both operands have an associated 'BufSpan'.
cmpBufSpan :: HasDebugCallStack => Located a -> Located a -> Ordering
cmpBufSpan (L l1 _) (L l2 _)
- | Just a <- getBufSpan l1
- , Just b <- getBufSpan l2
+ | Strict.Just a <- getBufSpan l1
+ , Strict.Just b <- getBufSpan l2
= compare a b
| otherwise = panic "cmpBufSpan: no BufSpan"
@@ -787,7 +788,7 @@ instance (Outputable e) => Outputable (Located e) where
instance (Outputable e) => Outputable (GenLocated RealSrcSpan e) where
ppr (L l e) = -- GenLocated:
-- Print spans without the file name etc
- whenPprDebug (braces (pprUserSpan False (RealSrcSpan l Nothing)))
+ whenPprDebug (braces (pprUserSpan False (RealSrcSpan l Strict.Nothing)))
$$ ppr e
@@ -882,7 +883,7 @@ psSpanEnd :: PsSpan -> PsLoc
psSpanEnd (PsSpan r b) = PsLoc (realSrcSpanEnd r) (bufSpanEnd b)
mkSrcSpanPs :: PsSpan -> SrcSpan
-mkSrcSpanPs (PsSpan r b) = RealSrcSpan r (Just b)
+mkSrcSpanPs (PsSpan r b) = RealSrcSpan r (Strict.Just b)
-- | Layout information for declarations.
data LayoutInfo =
diff --git a/compiler/GHC/Utils/Binary.hs b/compiler/GHC/Utils/Binary.hs
index 51918c87e3..17fa675986 100644
--- a/compiler/GHC/Utils/Binary.hs
+++ b/compiler/GHC/Utils/Binary.hs
@@ -82,6 +82,7 @@ import GHC.Types.Unique.FM
import GHC.Data.FastMutInt
import GHC.Utils.Fingerprint
import GHC.Types.SrcLoc
+import qualified GHC.Data.Strict as Strict
import Control.DeepSeq
import Foreign hiding (shiftL, shiftR)
@@ -704,6 +705,15 @@ instance Binary a => Binary (Maybe a) where
0 -> return Nothing
_ -> do x <- get bh; return (Just x)
+instance Binary a => Binary (Strict.Maybe a) where
+ put_ bh Strict.Nothing = putByte bh 0
+ put_ bh (Strict.Just a) = do putByte bh 1; put_ bh a
+ get bh =
+ do h <- getWord8 bh
+ case h of
+ 0 -> return Strict.Nothing
+ _ -> do x <- get bh; return (Strict.Just x)
+
instance (Binary a, Binary b) => Binary (Either a b) where
put_ bh (Left a) = do putByte bh 0; put_ bh a
put_ bh (Right b) = do putByte bh 1; put_ bh b
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 0d6e92cf6e..29762bd79f 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -371,6 +371,7 @@ Library
GHC.Data.OrdList
GHC.Data.Pair
GHC.Data.Stream
+ GHC.Data.Strict
GHC.Data.StringBuffer
GHC.Data.TrieMap
GHC.Driver.Backend
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index 4e90e930c2..9b520c7e23 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -101,6 +101,7 @@ import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
import qualified GHC.LanguageExtensions as LangExt
import GHC.Data.Bag (unitBag)
+import qualified GHC.Data.Strict as Strict
-- Haskell Libraries
import System.Console.Haskeline as Haskeline
@@ -3742,7 +3743,7 @@ stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg
Just loc -> do
md <- fromMaybe (panic "stepLocalCmd") <$> getCurrentBreakModule
current_toplevel_decl <- enclosingTickSpan md loc
- doContinue (`isSubspanOf` RealSrcSpan current_toplevel_decl Nothing) GHC.SingleStep
+ doContinue (`isSubspanOf` RealSrcSpan current_toplevel_decl Strict.Nothing) GHC.SingleStep
stepModuleCmd :: GhciMonad m => String -> m ()
stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg
@@ -4094,7 +4095,7 @@ findBreakAndSet md lookupTickTree = do
(alreadySet, nm) <-
recordBreak $ BreakLocation
{ breakModule = md
- , breakLoc = RealSrcSpan pan Nothing
+ , breakLoc = RealSrcSpan pan Strict.Nothing
, breakTick = tick
, onBreakCmd = ""
, breakEnabled = True
@@ -4156,7 +4157,7 @@ findBreakByCoord mb_file (line, col) arr
ticks = arr ! line
-- the ticks that span this coordinate
- contains = [ tick | tick@(_,pan) <- ticks, RealSrcSpan pan Nothing `spans` (line,col),
+ contains = [ tick | tick@(_,pan) <- ticks, RealSrcSpan pan Strict.Nothing `spans` (line,col),
is_correct_file pan ]
is_correct_file pan
diff --git a/ghc/GHCi/UI/Info.hs b/ghc/GHCi/UI/Info.hs
index db09243967..dcda66e634 100644
--- a/ghc/GHCi/UI/Info.hs
+++ b/ghc/GHCi/UI/Info.hs
@@ -48,6 +48,7 @@ import GHC.Utils.Outputable
import GHC.Types.SrcLoc
import GHC.Tc.Utils.Zonk
import GHC.Types.Var
+import qualified GHC.Data.Strict as Strict
-- | Info about a module. This information is generated every time a
-- module is loaded.
@@ -145,7 +146,7 @@ findNameUses infos span0 string =
locToSpans (modinfo,name',span') =
stripSurrounding (span' : map toSrcSpan spans)
where
- toSrcSpan s = RealSrcSpan (spaninfoSrcSpan s) Nothing
+ toSrcSpan s = RealSrcSpan (spaninfoSrcSpan s) Strict.Nothing
spans = filter ((== Just name') . fmap getName . spaninfoVar)
(modinfoSpans modinfo)
diff --git a/testsuite/tests/ghc-api/T19156.hs b/testsuite/tests/ghc-api/T19156.hs
index 999c1af242..21aad3f196 100644
--- a/testsuite/tests/ghc-api/T19156.hs
+++ b/testsuite/tests/ghc-api/T19156.hs
@@ -4,14 +4,15 @@
import GHC.Exts.Heap
import GHC.Types.SrcLoc
+import qualified GHC.Data.Strict as Strict
rsl :: RealSrcLoc
rsl = mkRealSrcLoc "Foo" 1 1
main = do
- let !s1 = RealSrcLoc rsl (Just (BufPos 999222))
- !s2 = RealSrcLoc rsl (Just (BufPos 999333))
- !s3 = RealSrcLoc rsl (Just (BufPos 999444))
+ let !s1 = RealSrcLoc rsl (Strict.Just (BufPos 999222))
+ !s2 = RealSrcLoc rsl (Strict.Just (BufPos 999333))
+ !s3 = RealSrcLoc rsl (Strict.Just (BufPos 999444))
!res = combineSrcSpans (combineSrcSpans (srcLocSpan s1) (srcLocSpan s2)) (srcLocSpan s3)
cs <- unbox res
diff --git a/testsuite/tests/ghc-api/all.T b/testsuite/tests/ghc-api/all.T
index 00e158516e..9ee14ba3ae 100644
--- a/testsuite/tests/ghc-api/all.T
+++ b/testsuite/tests/ghc-api/all.T
@@ -24,6 +24,6 @@ test('T18522-dbg-ppr',
extra_run_opts('"' + config.libdir + '"'),
compile_and_run,
['-package ghc'])
-test('T19156', [extra_run_opts('"' + config.libdir + '"'), expect_broken(19156)],
+test('T19156', extra_run_opts('"' + config.libdir + '"'),
compile_and_run,
['-package ghc'])
diff --git a/testsuite/tests/parser/should_run/CountAstDeps.stdout b/testsuite/tests/parser/should_run/CountAstDeps.stdout
index 242076d90c..c898dd7424 100644
--- a/testsuite/tests/parser/should_run/CountAstDeps.stdout
+++ b/testsuite/tests/parser/should_run/CountAstDeps.stdout
@@ -1,4 +1,4 @@
-Found 257 Language.Haskell.Syntax module dependencies
+Found 258 Language.Haskell.Syntax module dependencies
GHC.Builtin.Names
GHC.Builtin.PrimOps
GHC.Builtin.Types
@@ -76,6 +76,7 @@ GHC.Data.Maybe
GHC.Data.OrdList
GHC.Data.Pair
GHC.Data.Stream
+GHC.Data.Strict
GHC.Data.StringBuffer
GHC.Data.TrieMap
GHC.Driver.Backend
diff --git a/testsuite/tests/parser/should_run/CountParserDeps.stdout b/testsuite/tests/parser/should_run/CountParserDeps.stdout
index c08cd67a52..05d6073262 100644
--- a/testsuite/tests/parser/should_run/CountParserDeps.stdout
+++ b/testsuite/tests/parser/should_run/CountParserDeps.stdout
@@ -1,4 +1,4 @@
-Found 263 GHC.Parser module dependencies
+Found 264 GHC.Parser module dependencies
GHC.Builtin.Names
GHC.Builtin.PrimOps
GHC.Builtin.Types
@@ -76,6 +76,7 @@ GHC.Data.Maybe
GHC.Data.OrdList
GHC.Data.Pair
GHC.Data.Stream
+GHC.Data.Strict
GHC.Data.StringBuffer
GHC.Data.TrieMap
GHC.Driver.Backend