[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: perf: Replace uses of genericLength with strictGenericLength
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Thu Feb 6 17:55:40 UTC 2025
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
db19c8a9 by Matthew Pickering at 2025-02-05T23:16:50-05:00
perf: Replace uses of genericLength with strictGenericLength
genericLength is a recursive function and marked NOINLINE. It is not
going to specialise. In profiles, it can be seen that 3% of total compilation
time when computing bytecode is spend calling this non-specialised
function.
In addition, we can simplify `addListToSS` to avoid traversing the input
list twice and also allocating an intermediate list (after the call to
reverse).
Overall these changes reduce the time spend in 'assembleBCOs' from 5.61s
to 3.88s. Allocations drop from 8GB to 5.3G.
Fixes #25706
- - - - -
5622a14a by Matthew Pickering at 2025-02-05T23:17:27-05:00
perf: nameToCLabel: Directly manipulate ByteString rather than going via strings
`nameToCLabel` is called from `lookupHsSymbol` many times during
bytecode linking. We can save a lot of allocations and time by directly
manipulating the bytestrings rather than going via intermediate lists.
Before: 2GB allocation, 1.11s
After: 260MB allocation, 375ms
Fixes #25719
-------------------------
Metric Decrease:
MultiLayerModulesTH_OneShot
-------------------------
- - - - -
fd9c9f7f by Matthew Pickering at 2025-02-06T12:55:15-05:00
interpreter: Fix INTERP_STATS profiling code
The profiling code had slightly bitrotted since the last time it was
used. This just fixes things so that if you toggle the INTERP_STATS
macro then it just works and prints out the stats.
Fixes #25695
- - - - -
27f2df7a by Matthew Pickering at 2025-02-06T12:55:16-05:00
perf: Key the interpreter symbol cache by Name rather than FastString
Profiles showed that about 0.2s was being spend constructing the keys
before looking up values in the old symbol cache.
The performance of this codepath is critical as it translates directly
to a delay when a user evaluates a function like `main` in the
interpreter.
Therefore we implement a solution which keys the cache(s) by `Name`
rather than the symbol directly, so the cache can be consulted before
the symbol is constructed.
Fixes #25731
- - - - -
15 changed files:
- compiler/GHC.hs
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Linker.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Prelude/Basic.hs
- compiler/GHC/Runtime/Interpreter.hs
- compiler/GHC/Runtime/Interpreter/Types.hs
- + compiler/GHC/Runtime/Interpreter/Types/SymbolCache.hs
- compiler/GHC/StgToByteCode.hs
- compiler/ghc.cabal.in
- libraries/ghc-boot/GHC/Data/SizedSeq.hs
- rts/Interpreter.c
- rts/Interpreter.h
- rts/RtsMain.c
Changes:
=====================================
compiler/GHC.hs
=====================================
@@ -420,7 +420,6 @@ import GHC.Types.Name.Ppr
import GHC.Types.TypeEnv
import GHC.Types.Breakpoint
import GHC.Types.PkgQual
-import GHC.Types.Unique.FM
import GHC.Unit
import GHC.Unit.Env as UnitEnv
@@ -705,7 +704,7 @@ setTopSessionDynFlags :: GhcMonad m => DynFlags -> m ()
setTopSessionDynFlags dflags = do
hsc_env <- getSession
logger <- getLogger
- lookup_cache <- liftIO $ newMVar emptyUFM
+ lookup_cache <- liftIO $ mkInterpSymbolCache
-- Interpreter
interp <- if
=====================================
compiler/GHC/ByteCode/Asm.hs
=====================================
@@ -52,7 +52,6 @@ import Data.Array.Base ( UArray(..) )
import Foreign hiding (shiftL, shiftR)
import Data.Char ( ord )
-import Data.List ( genericLength )
import Data.Map.Strict (Map)
import Data.Maybe (fromMaybe)
import qualified Data.Map.Strict as Map
@@ -333,6 +332,7 @@ data InspectState = InspectState
, lblEnv :: LabelEnvMap
}
+
inspectAsm :: Platform -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap)
inspectAsm platform long_jumps initial_offset
= go (InspectState initial_offset 0 0 Map.empty)
@@ -340,7 +340,7 @@ inspectAsm platform long_jumps initial_offset
go s (NullAsm _) = (instrCount s, lblEnv s)
go s (AllocPtr _ k) = go (s { ptrCount = n + 1 }) (k n)
where n = ptrCount s
- go s (AllocLit ls k) = go (s { litCount = n + genericLength ls }) (k n)
+ go s (AllocLit ls k) = go (s { litCount = n + strictGenericLength ls }) (k n)
where n = litCount s
go s (AllocLabel lbl k) = go s' k
where s' = s { lblEnv = Map.insert lbl (instrCount s) (lblEnv s) }
=====================================
compiler/GHC/ByteCode/Linker.hs
=====================================
@@ -1,6 +1,8 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
--
-- (c) The University of Glasgow 2002-2006
@@ -11,7 +13,6 @@ module GHC.ByteCode.Linker
( linkBCO
, lookupStaticPtr
, lookupIE
- , nameToCLabel
, linkFail
)
where
@@ -25,7 +26,6 @@ import GHCi.ResolvedBCO
import GHC.Builtin.PrimOps
import GHC.Builtin.PrimOps.Ids
-import GHC.Builtin.Names
import GHC.Unit.Types
@@ -42,8 +42,6 @@ import GHC.Types.Name.Env
import qualified GHC.Types.Id as Id
import GHC.Types.Unique.DFM
-import Language.Haskell.Syntax.Module.Name
-
-- Standard libraries
import Data.Array.Unboxed
import Foreign.Ptr
@@ -91,30 +89,30 @@ lookupLiteral interp pkgs_loaded le ptr = case ptr of
lookupStaticPtr :: Interp -> FastString -> IO (Ptr ())
lookupStaticPtr interp addr_of_label_string = do
- m <- lookupSymbol interp addr_of_label_string
+ m <- lookupSymbol interp (IFaststringSymbol addr_of_label_string)
case m of
Just ptr -> return ptr
Nothing -> linkFail "GHC.ByteCode.Linker: can't find label"
- (unpackFS addr_of_label_string)
+ (ppr addr_of_label_string)
lookupIE :: Interp -> PkgsLoaded -> ItblEnv -> Name -> IO (Ptr ())
lookupIE interp pkgs_loaded ie con_nm =
case lookupNameEnv ie con_nm of
Just (_, ItblPtr a) -> return (fromRemotePtr (castRemotePtr a))
Nothing -> do -- try looking up in the object files.
- let sym_to_find1 = nameToCLabel con_nm "con_info"
- m <- lookupHsSymbol interp pkgs_loaded con_nm "con_info"
+ let sym_to_find1 = IConInfoSymbol con_nm
+ m <- lookupHsSymbol interp pkgs_loaded sym_to_find1
case m of
Just addr -> return addr
Nothing
-> do -- perhaps a nullary constructor?
- let sym_to_find2 = nameToCLabel con_nm "static_info"
- n <- lookupHsSymbol interp pkgs_loaded con_nm "static_info"
+ let sym_to_find2 = IStaticInfoSymbol con_nm
+ n <- lookupHsSymbol interp pkgs_loaded sym_to_find2
case n of
Just addr -> return addr
Nothing -> linkFail "GHC.ByteCode.Linker.lookupIE"
- (unpackFS sym_to_find1 ++ " or " ++
- unpackFS sym_to_find2)
+ (ppr sym_to_find1 <> " or " <>
+ ppr sym_to_find2)
-- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode
lookupAddr :: Interp -> PkgsLoaded -> AddrEnv -> Name -> IO (Ptr ())
@@ -122,21 +120,21 @@ lookupAddr interp pkgs_loaded ae addr_nm = do
case lookupNameEnv ae addr_nm of
Just (_, AddrPtr ptr) -> return (fromRemotePtr ptr)
Nothing -> do -- try looking up in the object files.
- let sym_to_find = nameToCLabel addr_nm "bytes"
+ let sym_to_find = IBytesSymbol addr_nm
-- see Note [Bytes label] in GHC.Cmm.CLabel
- m <- lookupHsSymbol interp pkgs_loaded addr_nm "bytes"
+ m <- lookupHsSymbol interp pkgs_loaded sym_to_find
case m of
Just ptr -> return ptr
Nothing -> linkFail "GHC.ByteCode.Linker.lookupAddr"
- (unpackFS sym_to_find)
+ (ppr sym_to_find)
lookupPrimOp :: Interp -> PkgsLoaded -> PrimOp -> IO (RemotePtr ())
lookupPrimOp interp pkgs_loaded primop = do
let sym_to_find = primopToCLabel primop "closure"
- m <- lookupHsSymbol interp pkgs_loaded (Id.idName $ primOpId primop) "closure"
+ m <- lookupHsSymbol interp pkgs_loaded (IClosureSymbol (Id.idName $ primOpId primop))
case m of
Just p -> return (toRemotePtr p)
- Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE(primop)" sym_to_find
+ Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE(primop)" (text sym_to_find)
resolvePtr
:: Interp
@@ -156,11 +154,11 @@ resolvePtr interp pkgs_loaded le bco_ix ptr = case ptr of
| otherwise
-> assertPpr (isExternalName nm) (ppr nm) $
do
- let sym_to_find = nameToCLabel nm "closure"
- m <- lookupHsSymbol interp pkgs_loaded nm "closure"
+ let sym_to_find = IClosureSymbol nm
+ m <- lookupHsSymbol interp pkgs_loaded sym_to_find
case m of
Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p))
- Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE" (unpackFS sym_to_find)
+ Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE" (ppr sym_to_find)
BCOPtrPrimOp op
-> ResolvedBCOStaticPtr <$> lookupPrimOp interp pkgs_loaded op
@@ -175,11 +173,10 @@ resolvePtr interp pkgs_loaded le bco_ix ptr = case ptr of
-- loaded units.
--
-- See Note [Looking up symbols in the relevant objects].
-lookupHsSymbol :: Interp -> PkgsLoaded -> Name -> String -> IO (Maybe (Ptr ()))
-lookupHsSymbol interp pkgs_loaded nm sym_suffix = do
- massertPpr (isExternalName nm) (ppr nm)
- let sym_to_find = nameToCLabel nm sym_suffix
- pkg_id = moduleUnitId $ nameModule nm
+lookupHsSymbol :: Interp -> PkgsLoaded -> InterpSymbol (Suffix s) -> IO (Maybe (Ptr ()))
+lookupHsSymbol interp pkgs_loaded sym_to_find = do
+ massertPpr (isExternalName (interpSymbolName sym_to_find)) (ppr sym_to_find)
+ let pkg_id = moduleUnitId $ nameModule (interpSymbolName sym_to_find)
loaded_dlls = maybe [] loaded_pkg_hs_dlls $ lookupUDFM pkgs_loaded pkg_id
go (dll:dlls) = do
@@ -193,12 +190,12 @@ lookupHsSymbol interp pkgs_loaded nm sym_suffix = do
go loaded_dlls
-linkFail :: String -> String -> IO a
+linkFail :: String -> SDoc -> IO a
linkFail who what
= throwGhcExceptionIO (ProgramError $
unlines [ "",who
, "During interactive linking, GHCi couldn't find the following symbol:"
- , ' ' : ' ' : what
+ , ' ' : ' ' : showSDocUnsafe what
, "This may be due to you not asking GHCi to load extra object files,"
, "archives or DLLs needed by your current session. Restart GHCi, specifying"
, "the missing library using the -L/path/to/object/dir and -lmissinglibname"
@@ -209,25 +206,8 @@ linkFail who what
])
-nameToCLabel :: Name -> String -> FastString
-nameToCLabel n suffix = mkFastString label
- where
- encodeZ = zString . zEncodeFS
- (Module pkgKey modName) = assert (isExternalName n) $ case nameModule n of
- -- Primops are exported from GHC.Prim, their HValues live in GHC.PrimopWrappers
- -- See Note [Primop wrappers] in GHC.Builtin.PrimOps.
- mod | mod == gHC_PRIM -> gHC_PRIMOPWRAPPERS
- mod -> mod
- packagePart = encodeZ (unitFS pkgKey)
- modulePart = encodeZ (moduleNameFS modName)
- occPart = encodeZ $ occNameMangledFS (nameOccName n)
-
- label = concat
- [ if pkgKey == mainUnit then "" else packagePart ++ "_"
- , modulePart
- , '_':occPart
- , '_':suffix
- ]
+
+
-- See Note [Primop wrappers] in GHC.Builtin.PrimOps
=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -2901,7 +2901,7 @@ jsCodeGen hsc_env srcspan i this_mod stg_binds_with_deps binding_id = do
jsLinkObject logger tmpfs tmp_dir js_config unit_env inst out_obj roots
-- look up "id_sym" closure and create a StablePtr (HValue) from it
- href <- lookupClosure interp (unpackFS id_sym) >>= \case
+ href <- lookupClosure interp (IFaststringSymbol id_sym) >>= \case
Nothing -> pprPanic "Couldn't find just linked TH closure" (ppr id_sym)
Just r -> pure r
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -217,12 +217,12 @@ loadName interp hsc_env name = do
case lookupNameEnv (closure_env (linker_env pls)) name of
Just (_,aa) -> return (pls,(aa, links, pkgs))
Nothing -> assertPpr (isExternalName name) (ppr name) $
- do let sym_to_find = nameToCLabel name "closure"
- m <- lookupClosure interp (unpackFS sym_to_find)
+ do let sym_to_find = IClosureSymbol name
+ m <- lookupClosure interp sym_to_find
r <- case m of
Just hvref -> mkFinalizedHValue interp hvref
Nothing -> linkFail "GHC.Linker.Loader.loadName"
- (unpackFS sym_to_find)
+ (ppr sym_to_find)
return (pls,(r, links, pkgs))
loadDependencies
@@ -909,7 +909,7 @@ dynLoadObjs interp hsc_env pls at LoaderState{..} objs = do
m <- loadDLL interp soFile
case m of
Right _ -> return $! pls { temp_sos = (libPath, libName) : temp_sos }
- Left err -> linkFail msg err
+ Left err -> linkFail msg (text err)
where
msg = "GHC.Linker.Loader.dynLoadObjs: Loading temp shared object failed"
=====================================
compiler/GHC/Prelude/Basic.hs
=====================================
@@ -25,6 +25,8 @@ module GHC.Prelude.Basic
, shiftL, shiftR
, setBit, clearBit
, head, tail
+
+ , strictGenericLength
) where
@@ -130,3 +132,15 @@ head = Prelude.head
tail :: HasCallStack => [a] -> [a]
tail = Prelude.tail
{-# INLINE tail #-}
+
+{- |
+The 'genericLength' function defined in base can't be specialised due to the
+NOINLINE pragma.
+
+It is also not strict in the accumulator, and strictGenericLength is not exported.
+
+See #25706 for why it is important to use a strict, specialised version.
+
+-}
+strictGenericLength :: Num a => [x] -> a
+strictGenericLength = fromIntegral . length
=====================================
compiler/GHC/Runtime/Interpreter.hs
=====================================
@@ -1,5 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
-- | Interacting with the iserv interpreter, whether it is running on an
-- external process or in the current process.
@@ -83,7 +84,6 @@ import GHC.Data.Maybe
import GHC.Data.FastString
import GHC.Types.SrcLoc
-import GHC.Types.Unique.FM
import GHC.Types.Basic
import GHC.Utils.Panic
@@ -116,6 +116,12 @@ import GHC.Stack.CCS (CostCentre,CostCentreStack)
import System.Directory
import System.Process
+import GHC.Builtin.Names
+import GHC.Types.Name
+
+-- Standard libraries
+import GHC.Exts
+
{- Note [Remote GHCi]
~~~~~~~~~~~~~~~~~~
When the flag -fexternal-interpreter is given to GHC, interpreted code
@@ -457,38 +463,65 @@ handleSeqHValueStatus interp unit_env eval_status =
initObjLinker :: Interp -> IO ()
initObjLinker interp = interpCmd interp InitLinker
-lookupSymbol :: Interp -> FastString -> IO (Maybe (Ptr ()))
+lookupSymbol :: Interp -> InterpSymbol s -> IO (Maybe (Ptr ()))
lookupSymbol interp str = withSymbolCache interp str $
case interpInstance interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
- InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str))
+ InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS (interpSymbolToCLabel str)))
#endif
ExternalInterp ext -> case ext of
ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do
uninterruptibleMask_ $
- sendMessage inst (LookupSymbol (unpackFS str))
+ sendMessage inst (LookupSymbol (unpackFS (interpSymbolToCLabel str)))
ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str)
ExtWasm i -> withWasmInterp i $ \inst -> fmap fromRemotePtr <$> do
uninterruptibleMask_ $
- sendMessage inst (LookupSymbol (unpackFS str))
+ sendMessage inst (LookupSymbol (unpackFS (interpSymbolToCLabel str)))
-lookupSymbolInDLL :: Interp -> RemotePtr LoadedDLL -> FastString -> IO (Maybe (Ptr ()))
+lookupSymbolInDLL :: Interp -> RemotePtr LoadedDLL -> InterpSymbol s -> IO (Maybe (Ptr ()))
lookupSymbolInDLL interp dll str = withSymbolCache interp str $
case interpInstance interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
- InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (unpackFS str))
+ InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (unpackFS (interpSymbolToCLabel str)))
#endif
ExternalInterp ext -> case ext of
ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do
uninterruptibleMask_ $
- sendMessage inst (LookupSymbolInDLL dll (unpackFS str))
+ sendMessage inst (LookupSymbolInDLL dll (unpackFS (interpSymbolToCLabel str)))
ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str)
-- wasm dyld doesn't track which symbol comes from which .so
ExtWasm {} -> lookupSymbol interp str
-lookupClosure :: Interp -> String -> IO (Maybe HValueRef)
+interpSymbolToCLabel :: forall s . InterpSymbol s -> FastString
+interpSymbolToCLabel s = eliminateInterpSymbol s interpretedInterpSymbol $ \is ->
+ let
+ n = interpSymbolName is
+ suffix = interpSymbolSuffix is
+
+ encodeZ = fastZStringToByteString . zEncodeFS
+ (Module pkgKey modName) = assert (isExternalName n) $ case nameModule n of
+ -- Primops are exported from GHC.Prim, their HValues live in GHC.PrimopWrappers
+ -- See Note [Primop wrappers] in GHC.Builtin.PrimOps.
+ mod | mod == gHC_PRIM -> gHC_PRIMOPWRAPPERS
+ mod -> mod
+ packagePart = encodeZ (unitFS pkgKey)
+ modulePart = encodeZ (moduleNameFS modName)
+ occPart = encodeZ $ occNameMangledFS (nameOccName n)
+
+ label = mconcat $
+ [ packagePart `mappend` "_" | pkgKey /= mainUnit ]
+ ++
+ [modulePart
+ , "_"
+ , occPart
+ , "_"
+ , fromString suffix
+ ]
+ in mkFastStringByteString label
+
+lookupClosure :: Interp -> InterpSymbol s -> IO (Maybe HValueRef)
lookupClosure interp str =
- interpCmd interp (LookupClosure str)
+ interpCmd interp (LookupClosure (unpackFS (interpSymbolToCLabel str)))
-- | 'withSymbolCache' tries to find a symbol in the 'interpLookupSymbolCache'
-- which maps symbols to the address where they are loaded.
@@ -496,7 +529,7 @@ lookupClosure interp str =
-- a miss we run the action which determines the symbol's address and populate
-- the cache with the answer.
withSymbolCache :: Interp
- -> FastString
+ -> InterpSymbol s
-- ^ The symbol we are looking up in the cache
-> IO (Maybe (Ptr ()))
-- ^ An action which determines the address of the symbol we
@@ -513,21 +546,19 @@ withSymbolCache interp str determine_addr = do
-- The analysis in #23415 further showed this cache should also benefit the
-- internal interpreter's loading times, and needn't be used by the external
-- interpreter only.
- cache <- readMVar (interpLookupSymbolCache interp)
- case lookupUFM cache str of
- Just p -> return (Just p)
+ cached_val <- lookupInterpSymbolCache str (interpSymbolCache interp)
+ case cached_val of
+ Just {} -> return cached_val
Nothing -> do
-
maddr <- determine_addr
case maddr of
Nothing -> return Nothing
Just p -> do
- let upd_cache cache' = addToUFM cache' str p
- modifyMVar_ (interpLookupSymbolCache interp) (pure . upd_cache)
- return (Just p)
+ updateInterpSymbolCache str (interpSymbolCache interp) p
+ return maddr
purgeLookupSymbolCache :: Interp -> IO ()
-purgeLookupSymbolCache interp = modifyMVar_ (interpLookupSymbolCache interp) (const (pure emptyUFM))
+purgeLookupSymbolCache interp = purgeInterpSymbolCache (interpSymbolCache interp)
-- | loadDLL loads a dynamic library using the OS's native linker
-- (i.e. dlopen() on Unix, LoadLibrary() on Windows). It takes either
=====================================
compiler/GHC/Runtime/Interpreter/Types.hs
=====================================
@@ -1,4 +1,6 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE RecordWildCards #-}
-- | Types used by the runtime interpreter
module GHC.Runtime.Interpreter.Types
@@ -10,6 +12,20 @@ module GHC.Runtime.Interpreter.Types
, ExtInterpInstance (..)
, ExtInterpState (..)
, InterpStatus(..)
+ -- * InterpSymbolCache
+ , InterpSymbolCache(..)
+ , mkInterpSymbolCache
+ , lookupInterpSymbolCache
+ , updateInterpSymbolCache
+ , purgeInterpSymbolCache
+ , InterpSymbol(..)
+ , SuffixOrInterpreted(..)
+ , interpSymbolName
+ , interpSymbolSuffix
+ , eliminateInterpSymbol
+ , interpretedInterpSymbol
+
+
-- * IServ
, IServ
, IServConfig(..)
@@ -30,9 +46,6 @@ import GHC.Linker.Types
import GHCi.RemoteTypes
import GHCi.Message ( Pipe )
-import GHC.Types.Unique.FM
-import GHC.Data.FastString ( FastString )
-import Foreign
import GHC.Platform
import GHC.Utils.TmpFs
@@ -42,6 +55,7 @@ import GHC.Unit.State
import GHC.Unit.Types
import GHC.StgToJS.Types
import GHC.StgToJS.Linker.Types
+import GHC.Runtime.Interpreter.Types.SymbolCache
import Control.Concurrent
import System.Process ( ProcessHandle, CreateProcess )
@@ -56,7 +70,7 @@ data Interp = Interp
, interpLoader :: !Loader
-- ^ Interpreter loader
- , interpLookupSymbolCache :: !(MVar (UniqFM FastString (Ptr ())))
+ , interpSymbolCache :: !InterpSymbolCache
-- ^ LookupSymbol cache
}
=====================================
compiler/GHC/Runtime/Interpreter/Types/SymbolCache.hs
=====================================
@@ -0,0 +1,142 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE RecordWildCards #-}
+
+-- | The SymbolCache is used to cache lookups for specific symbols when using
+-- the interpreter.
+module GHC.Runtime.Interpreter.Types.SymbolCache (
+ InterpSymbolCache(..)
+ , mkInterpSymbolCache
+ , lookupInterpSymbolCache
+ , updateInterpSymbolCache
+ , purgeInterpSymbolCache
+ , InterpSymbol(..)
+ , SuffixOrInterpreted(..)
+ , interpSymbolName
+ , interpSymbolSuffix
+ , eliminateInterpSymbol
+ , interpretedInterpSymbol
+ ) where
+
+import GHC.Prelude
+
+import GHC.Types.Unique.FM
+import GHC.Types.Name
+import GHC.Data.FastString
+import Foreign
+
+import Control.Concurrent
+import GHC.Utils.Outputable
+import GHC.TypeLits
+
+
+-- The symbols records the suffix which each cache deals with.
+newtype SymbolCache (s :: Symbol) = SymbolCache { _getSymbolCache :: UniqFM Name (Ptr ()) }
+
+-- Each cache is keyed by Name, there is one cache for each type of symbol we will
+-- potentially lookup. The caches are keyed by 'Name' so that it is not necessary to consult
+-- a complicated `FastString` each time.
+data InterpSymbolCache = InterpSymbolCache {
+ interpClosureCache :: MVar (SymbolCache "closure")
+ , interpConInfoCache :: MVar (SymbolCache "con_info")
+ , interpStaticInfoCache :: MVar (SymbolCache "static_info")
+ , interpBytesCache :: MVar (SymbolCache "bytes")
+ , interpFaststringCache :: MVar (UniqFM FastString (Ptr ()))
+ }
+
+data SuffixOrInterpreted = Suffix Symbol | Interpreted
+
+data InterpSymbol (s :: SuffixOrInterpreted) where
+ IClosureSymbol :: Name -> InterpSymbol (Suffix "closure")
+ IConInfoSymbol :: Name -> InterpSymbol (Suffix "con_info")
+ IStaticInfoSymbol :: Name -> InterpSymbol (Suffix "static_info")
+ IBytesSymbol :: Name -> InterpSymbol (Suffix "bytes")
+ IFaststringSymbol :: FastString -> InterpSymbol Interpreted
+
+instance Outputable (InterpSymbol s) where
+ ppr s = eliminateInterpSymbol s
+ (\(IFaststringSymbol s) -> text "interpreted:" <> ppr s)
+ (\s -> text (interpSymbolSuffix s) <> colon <> ppr (interpSymbolName s))
+
+eliminateInterpSymbol :: InterpSymbol s -> (InterpSymbol Interpreted -> r)
+ -> (forall x . InterpSymbol (Suffix x) -> r)
+ -> r
+eliminateInterpSymbol s k1 k2 =
+ case s of
+ IFaststringSymbol {} -> k1 s
+ IBytesSymbol {} -> k2 s
+ IStaticInfoSymbol {} -> k2 s
+ IConInfoSymbol {} -> k2 s
+ IClosureSymbol {} -> k2 s
+
+
+interpSymbolName :: InterpSymbol (Suffix s) -> Name
+interpSymbolName (IClosureSymbol n) = n
+interpSymbolName (IConInfoSymbol n) = n
+interpSymbolName (IStaticInfoSymbol n) = n
+interpSymbolName (IBytesSymbol n) = n
+
+interpretedInterpSymbol :: InterpSymbol Interpreted -> FastString
+interpretedInterpSymbol (IFaststringSymbol s) = s
+
+interpSymbolSuffix :: InterpSymbol (Suffix s) -> String
+interpSymbolSuffix (IClosureSymbol {}) = "closure"
+interpSymbolSuffix (IConInfoSymbol {}) = "con_info"
+interpSymbolSuffix (IStaticInfoSymbol {}) = "static_info"
+interpSymbolSuffix (IBytesSymbol {}) = "bytes"
+
+emptySymbolCache :: SymbolCache s
+emptySymbolCache = SymbolCache emptyUFM
+
+lookupSymbolCache :: InterpSymbol (Suffix s) -> SymbolCache s -> Maybe (Ptr ())
+lookupSymbolCache s (SymbolCache cache) = lookupUFM cache (interpSymbolName s)
+
+insertSymbolCache :: InterpSymbol (Suffix s) -> Ptr () -> SymbolCache s -> SymbolCache s
+insertSymbolCache s v (SymbolCache cache) = SymbolCache (addToUFM cache (interpSymbolName s) v)
+
+lookupInterpSymbolCache :: InterpSymbol s -> InterpSymbolCache -> IO (Maybe (Ptr ()))
+lookupInterpSymbolCache = withInterpSymbolCache
+ (\(IFaststringSymbol f) mvar_var -> (\cache -> lookupUFM cache f) <$> readMVar mvar_var)
+ (\s mvar_var -> lookupSymbolCache s <$> readMVar mvar_var)
+
+
+updateInterpSymbolCache :: InterpSymbol s
+ -> InterpSymbolCache -> Ptr () -> IO ()
+updateInterpSymbolCache = withInterpSymbolCache
+ (\(IFaststringSymbol f) mvar_var v -> modifyMVar_ mvar_var (\cache -> pure $ addToUFM cache f v))
+ (\s mvar_var v -> modifyMVar_ mvar_var (\cache -> pure $ insertSymbolCache s v cache))
+
+withInterpSymbolCache ::
+ (InterpSymbol Interpreted -> MVar (UniqFM FastString (Ptr ())) -> r)
+ -> (forall x . InterpSymbol (Suffix x) -> MVar (SymbolCache x) -> r)
+ -> InterpSymbol s
+ -> InterpSymbolCache
+ -> r
+withInterpSymbolCache k1 k2 key InterpSymbolCache{..} =
+ case key of
+ IClosureSymbol {} -> k2 key interpClosureCache
+ IConInfoSymbol {} -> k2 key interpConInfoCache
+ IStaticInfoSymbol {} -> k2 key interpStaticInfoCache
+ IBytesSymbol {} -> k2 key interpBytesCache
+ IFaststringSymbol {} -> k1 key interpFaststringCache
+
+-- | Clear all symbol caches.
+purgeInterpSymbolCache :: InterpSymbolCache -> IO ()
+purgeInterpSymbolCache (InterpSymbolCache a b c d e) = do
+ modifyMVar_ a (\_ -> do
+ modifyMVar_ b (\_ -> do
+ modifyMVar_ c (\_ -> do
+ modifyMVar_ d (\_ -> do
+ modifyMVar_ e (\_ -> pure emptyUFM)
+ pure emptySymbolCache)
+ pure emptySymbolCache)
+ pure emptySymbolCache)
+ pure emptySymbolCache)
+
+mkInterpSymbolCache :: IO InterpSymbolCache
+mkInterpSymbolCache = do
+ InterpSymbolCache <$> newMVar emptySymbolCache
+ <*> newMVar emptySymbolCache
+ <*> newMVar emptySymbolCache
+ <*> newMVar emptySymbolCache
+ <*> newMVar emptyUFM
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -70,7 +70,7 @@ import GHC.Types.Name.Env (mkNameEnv)
import GHC.Types.Tickish
import GHC.Types.SptEntry
-import Data.List ( genericReplicate, genericLength, intersperse
+import Data.List ( genericReplicate, intersperse
, partition, scanl', sortBy, zip4, zip6 )
import Foreign hiding (shiftL, shiftR)
import Control.Monad
@@ -394,7 +394,7 @@ schemeR_wrk fvs nm original_body (args, body)
-- make the arg bitmap
bits = argBits platform (reverse (map (idArgRep platform) all_args))
- bitmap_size = genericLength bits
+ bitmap_size = strictGenericLength bits
bitmap = mkBitmap platform bits
body_code <- schemeER_wrk sum_szsb_args p_init body
@@ -608,7 +608,7 @@ schemeE d s p (StgLet _ext binds body) = do
platform <- targetPlatform <$> getDynFlags
let (xs,rhss) = case binds of StgNonRec x rhs -> ([x],[rhs])
StgRec xs_n_rhss -> unzip xs_n_rhss
- n_binds = genericLength xs
+ n_binds = strictGenericLength xs
fvss = map (fvsToEnv p') rhss
@@ -617,7 +617,7 @@ schemeE d s p (StgLet _ext binds body) = do
sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss
-- the arity of each rhs
- arities = map (genericLength . fst . collect) rhss
+ arities = map (strictGenericLength . fst . collect) rhss
-- This p', d' defn is safe because all the items being pushed
-- are ptrs, so all have size 1 word. d' and p' reflect the stack
@@ -1858,7 +1858,7 @@ implement_tagToId
implement_tagToId d s p arg names
= assert (notNull names) $
do (push_arg, arg_bytes) <- pushAtom d p (StgVarArg arg)
- labels <- getLabelsBc (genericLength names)
+ labels <- getLabelsBc (strictGenericLength names)
label_fail <- getLabelBc
label_exit <- getLabelBc
dflags <- getDynFlags
=====================================
compiler/ghc.cabal.in
=====================================
@@ -699,6 +699,7 @@ Library
GHC.Runtime.Interpreter.JS
GHC.Runtime.Interpreter.Process
GHC.Runtime.Interpreter.Types
+ GHC.Runtime.Interpreter.Types.SymbolCache
GHC.Runtime.Interpreter.Wasm
GHC.Runtime.Loader
GHC.Runtime.Utils
=====================================
libraries/ghc-boot/GHC/Data/SizedSeq.hs
=====================================
@@ -1,4 +1,4 @@
-{-# LANGUAGE StandaloneDeriving, DeriveGeneric #-}
+{-# LANGUAGE StandaloneDeriving, DeriveGeneric, CPP #-}
module GHC.Data.SizedSeq
( SizedSeq(..)
, emptySS
@@ -11,9 +11,12 @@ module GHC.Data.SizedSeq
import Prelude -- See note [Why do we import Prelude here?]
import Control.DeepSeq
import Data.Binary
-import Data.List (genericLength)
import GHC.Generics
+#if ! MIN_VERSION_base(4,20,0)
+import Data.List (foldl')
+#endif
+
data SizedSeq a = SizedSeq {-# UNPACK #-} !Word [a]
deriving (Generic, Show)
@@ -37,9 +40,9 @@ emptySS = SizedSeq 0 []
addToSS :: SizedSeq a -> a -> SizedSeq a
addToSS (SizedSeq n r_xs) x = SizedSeq (n+1) (x:r_xs)
+-- NB, important this is eta-expand so that foldl' is inlined.
addListToSS :: SizedSeq a -> [a] -> SizedSeq a
-addListToSS (SizedSeq n r_xs) xs
- = SizedSeq (n + genericLength xs) (reverse xs ++ r_xs)
+addListToSS s xs = foldl' addToSS s xs
ssElts :: SizedSeq a -> [a]
ssElts (SizedSeq _ r_xs) = reverse r_xs
=====================================
rts/Interpreter.c
=====================================
@@ -182,6 +182,8 @@ int rts_stop_on_exception = 0;
#if defined(INTERP_STATS)
+#define N_CODES 128
+
/* Hacky stats, for tuning the interpreter ... */
int it_unknown_entries[N_CLOSURE_TYPES];
int it_total_unknown_entries;
@@ -195,8 +197,8 @@ int it_slides;
int it_insns;
int it_BCO_entries;
-int it_ofreq[27];
-int it_oofreq[27][27];
+int it_ofreq[N_CODES];
+int it_oofreq[N_CODES][N_CODES];
int it_lastopc;
@@ -210,9 +212,9 @@ void interp_startup ( void )
for (i = 0; i < N_CLOSURE_TYPES; i++)
it_unknown_entries[i] = 0;
it_slides = it_insns = it_BCO_entries = 0;
- for (i = 0; i < 27; i++) it_ofreq[i] = 0;
- for (i = 0; i < 27; i++)
- for (j = 0; j < 27; j++)
+ for (i = 0; i < N_CODES; i++) it_ofreq[i] = 0;
+ for (i = 0; i < N_CODES; i++)
+ for (j = 0; j < N_CODES; j++)
it_oofreq[i][j] = 0;
it_lastopc = 0;
}
@@ -234,14 +236,14 @@ void interp_shutdown ( void )
}
debugBelch("%d insns, %d slides, %d BCO_entries\n",
it_insns, it_slides, it_BCO_entries);
- for (i = 0; i < 27; i++)
+ for (i = 0; i < N_CODES; i++)
debugBelch("opcode %2d got %d\n", i, it_ofreq[i] );
for (k = 1; k < 20; k++) {
o_max = 0;
i_max = j_max = 0;
- for (i = 0; i < 27; i++) {
- for (j = 0; j < 27; j++) {
+ for (i = 0; i < N_CODES; i++) {
+ for (j = 0; j < N_CODES; j++) {
if (it_oofreq[i][j] > o_max) {
o_max = it_oofreq[i][j];
i_max = i; j_max = j;
@@ -259,6 +261,12 @@ void interp_shutdown ( void )
#else // !INTERP_STATS
+void interp_startup( void ){
+}
+
+void interp_shutdown( void ){
+}
+
#define INTERP_TICK(n) /* nothing */
#endif
@@ -419,7 +427,7 @@ eval:
eval_obj:
obj = UNTAG_CLOSURE(tagged_obj);
- INTERP_TICK(it_total_evals);
+ INTERP_TICK(it_total_entries);
IF_DEBUG(interpreter,
debugBelch(
@@ -1098,7 +1106,7 @@ run_BCO:
INTERP_TICK(it_insns);
#if defined(INTERP_STATS)
- ASSERT( (int)instrs[bciPtr] >= 0 && (int)instrs[bciPtr] < 27 );
+ ASSERT( (int)instrs[bciPtr] >= 0 && (int)instrs[bciPtr] < N_CODES );
it_ofreq[ (int)instrs[bciPtr] ] ++;
it_oofreq[ it_lastopc ][ (int)instrs[bciPtr] ] ++;
it_lastopc = (int)instrs[bciPtr];
=====================================
rts/Interpreter.h
=====================================
@@ -9,3 +9,5 @@
#pragma once
RTS_PRIVATE Capability *interpretBCO (Capability* cap);
+void interp_startup ( void );
+void interp_shutdown ( void );
=====================================
rts/RtsMain.c
=====================================
@@ -17,6 +17,7 @@
#include "Prelude.h"
#include "Task.h"
#include "Excn.h"
+#include "Interpreter.h"
#if defined(DEBUG)
# include "Printer.h" /* for printing */
@@ -56,6 +57,8 @@ int hs_main ( int argc, char *argv[], // program args
hs_init_ghc(&argc, &argv, rts_config);
+ interp_startup();
+
BEGIN_WINDOWS_VEH_HANDLER
// kick off the computation by creating the main thread with a pointer
@@ -96,6 +99,8 @@ int hs_main ( int argc, char *argv[], // program args
END_WINDOWS_VEH_HANDLER
+ interp_shutdown();
+
shutdownHaskellAndExit(exit_status, 0 /* !fastExit */);
// No code beyond this point. Dead code elimination will remove it
}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b666e6c8fcaf6cb2ed1f65ce7feae1bff4324669...27f2df7adfcd9ffbd04749d5aba962e84c39ff6b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b666e6c8fcaf6cb2ed1f65ce7feae1bff4324669...27f2df7adfcd9ffbd04749d5aba962e84c39ff6b
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/20250206/03afddc9/attachment-0001.html>
More information about the ghc-commits
mailing list