[Git][ghc/ghc][wip/compact-sourcetext] 3 commits: Use compact representation for SourceNotes

Zubin (@wz1000) gitlab at gitlab.haskell.org
Fri May 12 10:58:07 UTC 2023



Zubin pushed to branch wip/compact-sourcetext at Glasgow Haskell Compiler / GHC


Commits:
61be3880 by Zubin Duggal at 2023-05-12T16:27:50+05:30
Use compact representation for SourceNotes

Metric Decrease:
  hard_hole_fits

- - - - -
ff95b6d5 by Zubin Duggal at 2023-05-12T16:27:50+05:30
Use compact representation for UsageFile (#22744)

- - - - -
44027418 by Zubin Duggal at 2023-05-12T16:27:50+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
=====================================
@@ -5,11 +5,12 @@ 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 +68,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 "" ((\(LexicalFastString s) -> unpackFS s) . 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/403a9818044974ce86415909caef836ff98338fa...44027418ebd05b1311933f3f066a642ab5b5f06c

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/403a9818044974ce86415909caef836ff98338fa...44027418ebd05b1311933f3f066a642ab5b5f06c
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/3e8f4269/attachment-0001.html>


More information about the ghc-commits mailing list