[Git][ghc/ghc][wip/compact-sourcetext] 3 commits: Use compact representation for SourceNotes
Zubin (@wz1000)
gitlab at gitlab.haskell.org
Fri May 12 07:12:56 UTC 2023
Zubin pushed to branch wip/compact-sourcetext at Glasgow Haskell Compiler / GHC
Commits:
0a1070eb by Zubin Duggal at 2023-05-12T12:42:27+05:30
Use compact representation for SourceNotes
Metric Decrease:
hard_hole_fits
- - - - -
58ec6172 by Zubin Duggal at 2023-05-12T12:42:41+05:30
Use compact representation for UsageFile (#22744)
- - - - -
403a9818 by Zubin Duggal at 2023-05-12T12:42:41+05:30
testsuite: add test for T22744
- - - - -
22 changed files:
- compiler/GHC/Cmm/CLabel.hs
- compiler/GHC/Cmm/Parser.y
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
- compiler/GHC/CmmToAsm/Dwarf.hs
- compiler/GHC/CmmToAsm/PPC/CodeGen.hs
- compiler/GHC/CmmToAsm/X86/CodeGen.hs
- compiler/GHC/CoreToIface.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/HsToCore/Usage.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Stg/Debug.hs
- compiler/GHC/StgToCmm/InfoTableProv.hs
- compiler/GHC/Types/IPE.hs
- compiler/GHC/Types/Tickish.hs
- compiler/GHC/Unit/Module/Deps.hs
- testsuite/tests/perf/compiler/Makefile
- testsuite/tests/perf/compiler/all.T
- + testsuite/tests/perf/compiler/genT22744
Changes:
=====================================
compiler/GHC/Cmm/CLabel.hs
=====================================
@@ -839,7 +839,7 @@ data InfoProvEnt = InfoProvEnt
-- The rendered Haskell type of the closure the table represents
, infoProvModule :: !Module
-- Origin module
- , infoTableProv :: !(Maybe (RealSrcSpan, String)) }
+ , infoTableProv :: !(Maybe (RealSrcSpan, LexicalFastString)) }
-- Position and information about the info table
deriving (Eq, Ord)
=====================================
compiler/GHC/Cmm/Parser.y
=====================================
@@ -1496,7 +1496,7 @@ withSourceNote :: Located a -> Located b -> CmmParse c -> CmmParse c
withSourceNote a b parse = do
name <- getName
case combineSrcSpans (getLoc a) (getLoc b) of
- RealSrcSpan span _ -> code (emitTick (SourceNote span name)) >> parse
+ RealSrcSpan span _ -> code (emitTick (SourceNote span $ LexicalFastString $ mkFastString name)) >> parse
_other -> parse
-- -----------------------------------------------------------------------------
=====================================
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
=====================================
@@ -144,10 +144,10 @@ basicBlockCodeGen block = do
-- Generate location directive
dbg <- getDebugBlock (entryLabel block)
loc_instrs <- case dblSourceTick =<< dbg of
- Just (SourceNote span name)
+ Just (SourceNote span (LexicalFastString name))
-> do fileId <- getFileId (srcSpanFile span)
let line = srcSpanStartLine span; col = srcSpanStartCol span
- return $ unitOL $ LOCATION fileId line col name
+ return $ unitOL $ LOCATION fileId line col (unpackFS name)
_ -> return nilOL
(mid_instrs,mid_bid) <- stmtsToInstrs id stmts
(!tail_instrs,_) <- stmtToInstrs mid_bid tail
=====================================
compiler/GHC/CmmToAsm/Dwarf.hs
=====================================
@@ -6,6 +6,7 @@ import GHC.Prelude
import GHC.Cmm.CLabel
import GHC.Cmm.Expr
+import GHC.Data.FastString
import GHC.Settings.Config ( cProjectName, cProjectVersion )
import GHC.Types.Tickish ( CmmTickish, GenTickish(..) )
import GHC.Cmm.DebugBlock
@@ -177,7 +178,8 @@ procToDwarf :: NCGConfig -> DebugBlock -> DwarfInfo
procToDwarf config prc
= DwarfSubprogram { dwChildren = map (blockToDwarf config) (dblBlocks prc)
, dwName = case dblSourceTick prc of
- Just s at SourceNote{} -> sourceName s
+ Just s at SourceNote{} -> case sourceName s of
+ LexicalFastString s -> unpackFS s
_otherwise -> show (dblLabel prc)
, dwLabel = dblCLabel prc
, dwParent = fmap mkAsmTempDieLabel
=====================================
compiler/GHC/CmmToAsm/PPC/CodeGen.hs
=====================================
@@ -129,10 +129,10 @@ basicBlockCodeGen block = do
-- Generate location directive
dbg <- getDebugBlock (entryLabel block)
loc_instrs <- case dblSourceTick =<< dbg of
- Just (SourceNote span name)
+ Just (SourceNote span (LexicalFastString name))
-> do fileid <- getFileId (srcSpanFile span)
let line = srcSpanStartLine span; col =srcSpanStartCol span
- return $ unitOL $ LOCATION fileid line col name
+ return $ unitOL $ LOCATION fileid line col (unpackFS name)
_ -> return nilOL
mid_instrs <- stmtsToInstrs stmts
tail_instrs <- stmtToInstrs tail
=====================================
compiler/GHC/CmmToAsm/X86/CodeGen.hs
=====================================
@@ -196,10 +196,10 @@ basicBlockCodeGen block = do
-- Generate location directive
dbg <- getDebugBlock (entryLabel block)
loc_instrs <- case dblSourceTick =<< dbg of
- Just (SourceNote span name)
+ Just (SourceNote span (LexicalFastString name))
-> do fileId <- getFileId (srcSpanFile span)
let line = srcSpanStartLine span; col = srcSpanStartCol span
- return $ unitOL $ LOCATION fileId line col name
+ return $ unitOL $ LOCATION fileId line col (unpackFS name)
_ -> return nilOL
(mid_instrs,mid_bid) <- stmtsToInstrs id stmts
(!tail_instrs,_) <- stmtToInstrs mid_bid tail
=====================================
compiler/GHC/CoreToIface.hs
=====================================
@@ -578,7 +578,7 @@ toIfaceOneShot id | isId id
toIfaceTickish :: CoreTickish -> Maybe IfaceTickish
toIfaceTickish (ProfNote cc tick push) = Just (IfaceSCC cc tick push)
toIfaceTickish (HpcTick modl ix) = Just (IfaceHpcTick modl ix)
-toIfaceTickish (SourceNote src names) = Just (IfaceSource src names)
+toIfaceTickish (SourceNote src (LexicalFastString names)) = Just (IfaceSource src names)
toIfaceTickish (Breakpoint {}) = Nothing
-- Ignore breakpoints, since they are relevant only to GHCi, and
-- should not be serialised (#8333)
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -314,7 +314,7 @@ mkDataConWorkers generate_debug_info mod_loc data_tycons
| Just file <- ml_hs_file mod_loc = tick (span1 file)
| otherwise = tick (span1 "???")
where tick span = Tick $ SourceNote span $
- renderWithContext defaultSDocContext $ ppr name
+ LexicalFastString $ mkFastString $ renderWithContext defaultSDocContext $ ppr name
span1 file = realSrcLocSpan $ mkRealSrcLoc (mkFastString file) 1 1
{-
=====================================
compiler/GHC/HsToCore/Ticks.hs
=====================================
@@ -1182,24 +1182,23 @@ mkTickish boxLabel countEntries topOnly pos fvs decl_path = do
, tick_label = boxLabel
}
- cc_name | topOnly = head decl_path
- | otherwise = concat (intersperse "." decl_path)
+ cc_name | topOnly = mkFastString $ head decl_path
+ | otherwise = mkFastString $ concat (intersperse "." decl_path)
env <- getEnv
case tickishType env of
HpcTicks -> HpcTick (this_mod env) <$> addMixEntry me
ProfNotes -> do
- let nm = mkFastString cc_name
- flavour <- mkHpcCCFlavour <$> getCCIndexM nm
- let cc = mkUserCC nm (this_mod env) pos flavour
+ flavour <- mkHpcCCFlavour <$> getCCIndexM cc_name
+ let cc = mkUserCC cc_name (this_mod env) pos flavour
count = countEntries && tte_countEntries env
return $ ProfNote cc count True{-scopes-}
Breakpoints -> Breakpoint noExtField <$> addMixEntry me <*> pure ids
SourceNotes | RealSrcSpan pos' _ <- pos ->
- return $ SourceNote pos' cc_name
+ return $ SourceNote pos' $ LexicalFastString cc_name
_otherwise -> panic "mkTickish: bad source span!"
=====================================
compiler/GHC/HsToCore/Usage.hs
=====================================
@@ -35,6 +35,7 @@ import GHC.Unit.Module.ModIface
import GHC.Unit.Module.Deps
import GHC.Data.Maybe
+import GHC.Data.FastString
import Data.IORef
import Data.List (sortBy)
@@ -86,7 +87,7 @@ mkUsageInfo uc plugins fc unit_env this_mod dir_imp_mods used_names dependent_fi
let all_home_ids = ue_all_home_unit_ids unit_env
mod_usages <- mk_mod_usage_info uc hu all_home_ids this_mod
dir_imp_mods used_names
- let usages = mod_usages ++ [ UsageFile { usg_file_path = f
+ let usages = mod_usages ++ [ UsageFile { usg_file_path = mkFastString f
, usg_file_hash = hash
, usg_file_label = Nothing }
| (f, hash) <- zip dependent_files hashes ]
@@ -174,7 +175,7 @@ mkObjectUsage pit plugins fc hug th_links_needed th_pkgs_needed = do
msg m = moduleNameString (moduleName m) ++ "[TH] changed"
- fing mmsg fn = UsageFile fn <$> lookupFileCache fc fn <*> pure mmsg
+ fing mmsg fn = UsageFile (mkFastString fn) <$> lookupFileCache fc fn <*> pure mmsg
unlinkedToUsage m ul =
case nameOfObject_maybe ul of
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -1175,7 +1175,7 @@ pprUsage usage at UsageHomeModule{}
)
pprUsage usage at UsageFile{}
= hsep [text "addDependentFile",
- doubleQuotes (text (usg_file_path usage)),
+ doubleQuotes (ftext (usg_file_path usage)),
ppr (usg_file_hash usage)]
pprUsage usage at UsageMergedRequirement{}
= hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)]
=====================================
compiler/GHC/Iface/Recomp.hs
=====================================
@@ -771,12 +771,12 @@ checkModUsage fc UsageFile{ usg_file_path = file,
usg_file_label = mlabel } =
liftIO $
handleIO handler $ do
- new_hash <- lookupFileCache fc file
+ new_hash <- lookupFileCache fc $ unpackFS file
if (old_hash /= new_hash)
then return recomp
else return UpToDate
where
- reason = FileChanged file
+ reason = FileChanged $ unpackFS file
recomp = needsRecompileBecause $ fromMaybe reason $ fmap CustomReason mlabel
handler = if debugIsOn
then \e -> pprTrace "UsageFile" (text (show e)) $ return recomp
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -45,6 +45,7 @@ module GHC.Iface.Syntax (
import GHC.Prelude
+import GHC.Data.FastString
import GHC.Builtin.Names ( unrestrictedFunTyConKey, liftedTypeKindTyConKey,
constraintKindTyConKey )
import GHC.Types.Unique ( hasKey )
@@ -577,7 +578,7 @@ data IfaceExpr
data IfaceTickish
= IfaceHpcTick Module Int -- from HpcTick x
| IfaceSCC CostCentre Bool Bool -- from ProfNote
- | IfaceSource RealSrcSpan String -- from SourceNote
+ | IfaceSource RealSrcSpan FastString -- from SourceNote
-- no breakpoints: we never export these into interface files
data IfaceAlt = IfaceAlt IfaceConAlt [IfLclName] IfaceExpr
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -1651,7 +1651,7 @@ tcIfaceExpr (IfaceTick tickish expr) = do
tcIfaceTickish :: IfaceTickish -> IfM lcl CoreTickish
tcIfaceTickish (IfaceHpcTick modl ix) = return (HpcTick modl ix)
tcIfaceTickish (IfaceSCC cc tick push) = return (ProfNote cc tick push)
-tcIfaceTickish (IfaceSource src name) = return (SourceNote src name)
+tcIfaceTickish (IfaceSource src name) = return (SourceNote src (LexicalFastString name))
-------------------------
tcIfaceLit :: Literal -> IfL Literal
=====================================
compiler/GHC/Stg/Debug.hs
=====================================
@@ -16,7 +16,7 @@ import GHC.Types.Tickish
import GHC.Core.DataCon
import GHC.Types.IPE
import GHC.Unit.Module
-import GHC.Types.Name ( getName, getOccName, occNameString, nameSrcSpan)
+import GHC.Types.Name ( getName, getOccName, occNameFS, nameSrcSpan)
import GHC.Data.FastString
import Control.Monad (when)
@@ -29,7 +29,7 @@ import Control.Applicative
import qualified Data.List.NonEmpty as NE
import Data.List.NonEmpty (NonEmpty(..))
-data SpanWithLabel = SpanWithLabel RealSrcSpan String
+data SpanWithLabel = SpanWithLabel RealSrcSpan LexicalFastString
data StgDebugOpts = StgDebugOpts
{ stgDebug_infoTableMap :: !Bool
@@ -74,7 +74,7 @@ collectStgRhs bndr (StgRhsClosure ext cc us bs e t) = do
-- If the name has a span, use that initially as the source position in-case
-- we don't get anything better.
with_span = case nameSrcSpan name of
- RealSrcSpan pos _ -> withSpan (pos, occNameString (getOccName name))
+ RealSrcSpan pos _ -> withSpan (pos, LexicalFastString $ occNameFS (getOccName name))
_ -> id
e' <- with_span $ collectExpr e
recordInfo bndr e'
@@ -92,7 +92,7 @@ recordInfo bndr new_rhs = do
-- A span from the ticks surrounding the new_rhs
best_span = quickSourcePos thisFile new_rhs
-- A back-up span if the bndr had a source position, many do not (think internally generated ids)
- bndr_span = (\s -> SpanWithLabel s (occNameString (getOccName bndr)))
+ bndr_span = (\s -> SpanWithLabel s (LexicalFastString $ occNameFS (getOccName bndr)))
<$> srcSpanToRealSrcSpan (nameSrcSpan (getName bndr))
recordStgIdPosition bndr best_span bndr_span
=====================================
compiler/GHC/StgToCmm/InfoTableProv.hs
=====================================
@@ -1,15 +1,17 @@
module GHC.StgToCmm.InfoTableProv (emitIpeBufferListNode) where
+import Data.Coerce
import GHC.Prelude
import GHC.Platform
import GHC.Unit.Module
import GHC.Utils.Outputable
import GHC.Types.SrcLoc (pprUserRealSpan, srcSpanFile)
-import GHC.Data.FastString (fastStringToShortText)
+import GHC.Data.FastString (fastStringToShortText, unpackFS, LexicalFastString(..))
import GHC.Cmm.CLabel
import GHC.Cmm.Expr
import GHC.Cmm.Utils
+
import GHC.StgToCmm.Config
import GHC.StgToCmm.Lit (newByteStringCLit)
import GHC.StgToCmm.Monad
@@ -67,7 +69,7 @@ toCgIPE platform ctx module_name ipe = do
table_name <- lookupStringTable $ ST.pack $ renderWithContext ctx (pprCLabel platform (infoTablePtr ipe))
closure_desc <- lookupStringTable $ ST.pack $ show (infoProvEntClosureType ipe)
type_desc <- lookupStringTable $ ST.pack $ infoTableType ipe
- let label_str = maybe "" snd (infoTableProv ipe)
+ let label_str = maybe "" (unpackFS . coerce . snd) (infoTableProv ipe)
let (src_loc_file, src_loc_span) =
case infoTableProv ipe of
Nothing -> (mempty, "")
=====================================
compiler/GHC/Types/IPE.hs
=====================================
@@ -9,6 +9,7 @@ module GHC.Types.IPE (
import GHC.Prelude
import GHC.Types.Name
+import GHC.Data.FastString
import GHC.Types.SrcLoc
import GHC.Core.DataCon
@@ -20,7 +21,7 @@ import qualified Data.Map.Strict as Map
-- | Position and information about an info table.
-- For return frames these are the contents of a 'CoreSyn.SourceNote'.
-type IpeSourceLocation = (RealSrcSpan, String)
+type IpeSourceLocation = (RealSrcSpan, LexicalFastString)
-- | A map from a 'Name' to the best approximate source position that
-- name arose from.
=====================================
compiler/GHC/Types/Tickish.hs
=====================================
@@ -25,6 +25,7 @@ module GHC.Types.Tickish (
) where
import GHC.Prelude
+import GHC.Data.FastString
import GHC.Core.Type
@@ -153,8 +154,8 @@ data GenTickish pass =
-- necessary to enable optimizations.
| SourceNote
{ sourceSpan :: RealSrcSpan -- ^ Source covered
- , sourceName :: String -- ^ Name for source location
- -- (uses same names as CCs)
+ , sourceName :: LexicalFastString -- ^ Name for source location
+ -- (uses same names as CCs)
}
deriving instance Eq (GenTickish 'TickishPassCore)
=====================================
compiler/GHC/Unit/Module/Deps.hs
=====================================
@@ -21,6 +21,8 @@ where
import GHC.Prelude
+import GHC.Data.FastString
+
import GHC.Types.SafeHaskell
import GHC.Types.Name
@@ -275,7 +277,7 @@ data Usage
-- | A file upon which the module depends, e.g. a CPP #include, or using TH's
-- 'addDependentFile'
| UsageFile {
- usg_file_path :: FilePath,
+ usg_file_path :: FastString,
-- ^ External file dependency. From a CPP #include or TH
-- addDependentFile. Should be absolute.
usg_file_hash :: Fingerprint,
=====================================
testsuite/tests/perf/compiler/Makefile
=====================================
@@ -32,3 +32,8 @@ MultiLayerModulesTH_OneShot_Prep: MultiLayerModulesTH_Make_Prep
InstanceMatching:
./genMatchingTest 0
'$(TEST_HC)' $(TEST_HC_OPTS) -fno-code -fwrite-interface Defs.hs
+
+T22744:
+ ./genT22744
+ '$(TEST_HC)' $(TEST_HC_OPTS) T22744.hs
+
=====================================
testsuite/tests/perf/compiler/all.T
=====================================
@@ -670,3 +670,14 @@ test('RecordUpdPerf',
],
multimod_compile,
['RecordUpdPerf', '-fno-code -v0'])
+
+test('T22744',
+ [ collect_compiler_stats('peak_megabytes_allocated',20),
+ req_interp,
+ pre_cmd('$MAKE -s --no-print-directory T22744'),
+ extra_files(['genT22744']),
+ compile_timeout_multiplier(2)
+ ],
+ multimod_compile,
+ ['T22744', '-v0'])
+
=====================================
testsuite/tests/perf/compiler/genT22744
=====================================
@@ -0,0 +1,28 @@
+#!/usr/bin/env bash
+
+NUMDEP=10000
+NUMMOD=100
+
+seq 1 $NUMDEP | xargs -I{} touch foo{}
+
+cat > T22744.hs << EOF
+module Main where
+EOF
+
+for i in $(seq $NUMMOD); do
+ cat > M$i.hs << EOF
+{-# LANGUAGE TemplateHaskell #-}
+module M$i where
+import Language.Haskell.TH.Syntax
+import Control.Monad
+
+\$(do forM_ [1..$NUMDEP] $ \i -> addDependentFile $ "foo" ++ show i
+ return [])
+EOF
+ echo "import M$i" >> T22744.hs
+done
+
+cat >> T22744.hs << EOF
+main = pure ()
+EOF
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c4e26c8014d983576310f91ac67b588692d65a4a...403a9818044974ce86415909caef836ff98338fa
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c4e26c8014d983576310f91ac67b588692d65a4a...403a9818044974ce86415909caef836ff98338fa
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/20230512/5a029deb/attachment-0001.html>
More information about the ghc-commits
mailing list