diff options
author | Zubin Duggal <zubin.duggal@gmail.com> | 2023-05-04 05:30:13 +0530 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2023-05-16 14:00:00 -0400 |
commit | 90e69d5d167b9d6cd63b04e42f8af375dc4b307f (patch) | |
tree | 8ce2679872dbc4c4a5cc60025fe9564d36fc7772 /utils | |
parent | 5e3f9bb57680a40f6a9531e41dc2617c5f028e5c (diff) | |
download | haskell-90e69d5d167b9d6cd63b04e42f8af375dc4b307f.tar.gz |
compiler: Use compact representation for SourceText
SourceText is serialized along with INLINE pragmas into interface files. Many of
these SourceTexts are identical, for example "{-# INLINE#". When deserialized,
each such SourceText was previously expanded out into a [Char], which is highly
wasteful of memory, and each such instance of the text would allocate an
independent list with its contents as deserializing breaks any sharing that might
have existed.
Instead, we use a `FastString` to represent these, so that each instance unique
text will be interned and stored in a memory efficient manner.
Diffstat (limited to 'utils')
-rw-r--r-- | utils/check-exact/ExactPrint.hs | 26 |
1 files changed, 13 insertions, 13 deletions
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs index f4d4defb5b..97e35b0ebb 100644 --- a/utils/check-exact/ExactPrint.hs +++ b/utils/check-exact/ExactPrint.hs @@ -477,7 +477,7 @@ class (Typeable a) => ExactPrint a where printSourceText :: (Monad m, Monoid w) => SourceText -> String -> EP w m () printSourceText (NoSourceText) txt = printStringAdvance txt >> return () -printSourceText (SourceText txt) _ = printStringAdvance txt >> return () +printSourceText (SourceText txt) _ = printStringAdvance (unpackFS txt) >> return () -- --------------------------------------------------------------------- @@ -564,7 +564,7 @@ printStringAtAAC capture (EpaDelta d cs) s = do markExternalSourceText :: (Monad m, Monoid w) => SrcSpan -> SourceText -> String -> EP w m () markExternalSourceText l NoSourceText txt = printStringAtRs (realSrcSpan l) txt >> return () -markExternalSourceText l (SourceText txt) _ = printStringAtRs (realSrcSpan l) txt >> return () +markExternalSourceText l (SourceText txt) _ = printStringAtRs (realSrcSpan l) (unpackFS txt) >> return () -- --------------------------------------------------------------------- @@ -658,21 +658,21 @@ markAnnCloseP an = markEpAnnLMS' an lapr_close AnnClose (Just "#-}") markAnnOpenP :: (Monad m, Monoid w) => EpAnn AnnPragma -> SourceText -> String -> EP w m (EpAnn AnnPragma) markAnnOpenP an NoSourceText txt = markEpAnnLMS' an lapr_open AnnOpen (Just txt) -markAnnOpenP an (SourceText txt) _ = markEpAnnLMS' an lapr_open AnnOpen (Just txt) +markAnnOpenP an (SourceText txt) _ = markEpAnnLMS' an lapr_open AnnOpen (Just $ unpackFS txt) markAnnOpen :: (Monad m, Monoid w) => EpAnn [AddEpAnn] -> SourceText -> String -> EP w m (EpAnn [AddEpAnn]) markAnnOpen an NoSourceText txt = markEpAnnLMS an lidl AnnOpen (Just txt) -markAnnOpen an (SourceText txt) _ = markEpAnnLMS an lidl AnnOpen (Just txt) +markAnnOpen an (SourceText txt) _ = markEpAnnLMS an lidl AnnOpen (Just $ unpackFS txt) markAnnOpen' :: (Monad m, Monoid w) => Maybe EpaLocation -> SourceText -> String -> EP w m (Maybe EpaLocation) markAnnOpen' ms NoSourceText txt = printStringAtMLoc' ms txt -markAnnOpen' ms (SourceText txt) _ = printStringAtMLoc' ms txt +markAnnOpen' ms (SourceText txt) _ = printStringAtMLoc' ms $ unpackFS txt markAnnOpen'' :: (Monad m, Monoid w) => EpaLocation -> SourceText -> String -> EP w m EpaLocation markAnnOpen'' el NoSourceText txt = printStringAtAA el txt -markAnnOpen'' el (SourceText txt) _ = printStringAtAA el txt +markAnnOpen'' el (SourceText txt) _ = printStringAtAA el $ unpackFS txt -- --------------------------------------------------------------------- {- @@ -1795,7 +1795,7 @@ instance ExactPrint (RuleDecls GhcPs) where an0 <- case src of NoSourceText -> markEpAnnLMS an lidl AnnOpen (Just "{-# RULES") - SourceText srcTxt -> markEpAnnLMS an lidl AnnOpen (Just srcTxt) + SourceText srcTxt -> markEpAnnLMS an lidl AnnOpen (Just $ unpackFS srcTxt) rules' <- markAnnotated rules an1 <- markEpAnnLMS an0 lidl AnnClose (Just "#-}") return (HsRules (an1,src) rules') @@ -2715,7 +2715,7 @@ instance ExactPrint (HsExpr GhcPs) where printStringAtLsDelta (SameLine 0) "#" case src of NoSourceText -> printStringAtLsDelta (SameLine 0) (unpackFS l) - SourceText txt -> printStringAtLsDelta (SameLine 0) txt + SourceText txt -> printStringAtLsDelta (SameLine 0) (unpackFS txt) return x exact x@(HsIPVar _ (HsIPName n)) @@ -2727,7 +2727,7 @@ instance ExactPrint (HsExpr GhcPs) where HsFractional (FL { fl_text = src }) -> src HsIsString src _ -> src case str of - SourceText s -> printStringAdvance s >> return () + SourceText s -> printStringAdvance (unpackFS s) >> return () NoSourceText -> withPpr x >> return () return x @@ -3909,7 +3909,7 @@ instance ExactPrint (HsType GhcPs) where NoSourceText -> return an SourceText src -> do debugM $ "HsBangTy: src=" ++ showAst src - an0 <- markEpAnnLMS an lid AnnOpen (Just src) + an0 <- markEpAnnLMS an lid AnnOpen (Just $ unpackFS src) an1 <- markEpAnnLMS an0 lid AnnClose (Just "#-}") debugM $ "HsBangTy: done unpackedness" return an1 @@ -4678,7 +4678,7 @@ instance ExactPrint (HsOverLit GhcPs) where HsIsString src _ -> src in case str of - SourceText s -> printStringAdvance s >> return ol + SourceText s -> printStringAdvance (unpackFS s) >> return ol NoSourceText -> return ol -- --------------------------------------------------------------------- @@ -4710,11 +4710,11 @@ hsLit2String lit = toSourceTextWithSuffix :: (Show a) => SourceText -> a -> String -> String toSourceTextWithSuffix (NoSourceText) alt suffix = show alt ++ suffix -toSourceTextWithSuffix (SourceText txt) _alt suffix = txt ++ suffix +toSourceTextWithSuffix (SourceText txt) _alt suffix = unpackFS txt ++ suffix sourceTextToString :: SourceText -> String -> String sourceTextToString NoSourceText alt = alt -sourceTextToString (SourceText txt) _ = txt +sourceTextToString (SourceText txt) _ = unpackFS txt -- --------------------------------------------------------------------- |