From: Pepe Iborra Date: Wed, 21 Feb 2007 18:56:49 +0000 (+0000) Subject: Improving the performance of breakpoints up to 50% (by playing with laziness) X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=2bbec92eb827c0d70b25f4006a954d95ae3088bf Improving the performance of breakpoints up to 50% (by playing with laziness) This patch performs several optimizations with the goal of minimizing the cost of building the arguments to breakpointJump: - Group them all in a single tuple, to minimize closure creation in heap - Wrap this with the GHC.Base.lazy combinator, to induce max laziness - Remove as many literal strings as possible * injecting a module-local CAF to store the module name and use that * eliminating the package string (not needed). --- diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 27d4147..2a1f74f 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -23,6 +23,7 @@ import {-# SOURCE #-} Match( matchWrapper ) import DsMonad import DsGRHSs import DsUtils +import DsBreakpoint import HsSyn -- lots of things import CoreSyn -- lots of things @@ -46,6 +47,10 @@ import BasicTypes hiding ( TopLevel ) import FastString import Util ( mapSnd ) +import Name +import OccName +import Literal + import Control.Monad import Data.List \end{code} @@ -58,7 +63,21 @@ import Data.List \begin{code} dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)] -dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds +dsTopLHsBinds auto_scc binds = do + mb_mod_name_ref <- getModNameRefDs + case mb_mod_name_ref of + Just _ -> ds_lhs_binds auto_scc binds + Nothing -> do -- Inject a CAF with the module name as literal + mod <- getModuleDs + mod_name_ref <- do + u <- newUnique + let n = mkSystemName u (mkVarOcc "_module") + return (mkLocalId n stringTy) + let mod_name = moduleNameFS$ moduleName mod + mod_lit <- dsExpr (HsLit (HsString mod_name)) + withModNameRefDs mod_name_ref $ do + res <- ds_lhs_binds auto_scc binds + return$ (mod_name_ref, mod_lit) : res dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)] dsLHsBinds binds = ds_lhs_binds NoSccs binds diff --git a/compiler/deSugar/DsBreakpoint.lhs b/compiler/deSugar/DsBreakpoint.lhs index 07b3ec9..0282d6d 100644 --- a/compiler/deSugar/DsBreakpoint.lhs +++ b/compiler/deSugar/DsBreakpoint.lhs @@ -7,8 +7,8 @@ ----------------------------------------------------------------------------- \begin{code} -module DsBreakpoint( - dsAndThenMaybeInsertBreakpoint +module DsBreakpoint( debug_enabled + , dsAndThenMaybeInsertBreakpoint , maybeInsertBreakpoint , breakpoints_enabled , mkBreakpointExpr @@ -18,7 +18,6 @@ import TysPrim import TysWiredIn import PrelNames import Module -import PackageConfig import SrcLoc import TyCon import TypeRep @@ -47,14 +46,14 @@ import Control.Monad import Data.IORef import Foreign.StablePtr import GHC.Exts + #ifdef GHCI mkBreakpointExpr :: SrcSpan -> Id -> Type -> DsM (LHsExpr Id) mkBreakpointExpr loc bkptFuncId ty = do scope <- getScope mod <- getModuleDs u <- newUnique - let mod_name = moduleNameFS$ moduleName mod - valId = mkUserLocal (mkVarOcc "_result") u ty noSrcLoc + let valId = mkUserLocal (mkVarOcc "_result") u ty noSrcLoc when (not instrumenting) $ warnDs (text "Extracted ids:" <+> (ppr scope $$ ppr (map idType scope))) @@ -64,6 +63,7 @@ mkBreakpointExpr loc bkptFuncId ty = do else return 0 ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName jumpFuncId <- mkJumpFunc bkptFuncId + Just mod_name_ref <- getModNameRefDs let [opaqueDataCon] = tyConDataCons opaqueTyCon opaqueId = dataConWrapId opaqueDataCon opaqueTy = mkTyConApp opaqueTyCon [] @@ -73,22 +73,24 @@ mkBreakpointExpr loc bkptFuncId ty = do -- Yes, I know... I'm gonna burn in hell. Ptr addr# = castStablePtrToPtr stablePtr locals = ExplicitList opaqueTy (map wrapInOpaque scope) - locInfo = nlTuple [ HsLit (HsString (packageIdFS$ modulePackageId mod)) - , HsLit (HsString mod_name) + locInfo = nlTuple [ HsVar mod_name_ref , HsLit (HsInt (fromIntegral site))] funE = l$ HsVar jumpFuncId - ptrE = l (HsLit (HsInt (fromIntegral (I# (addr2Int# addr#))))) - locsE = l (HsApp (l(HsWrap (WpTyApp (mkListTy opaqueTy)) (HsVar lazyId))) - (l locals)) - locE = l locInfo - msgE = l (srcSpanLit loc) - return $ - l(l(l(l(funE `HsApp` ptrE) `HsApp` locsE) `HsApp` locE) `HsApp` msgE) + ptrE = (HsLit (HsInt (fromIntegral (I# (addr2Int# addr#))))) + locE = locInfo + msgE = srcSpanLit loc + argsE = nlTuple [ptrE, locals, msgE] + lazy_argsE = HsApp (l$ HsWrap (WpTyApp argsT) (HsVar lazyId)) (l argsE) + argsT = mkTupleType [intTy, mkListTy opaqueTy, stringTy] + return $ + l(l(funE `HsApp` l locE) `HsApp` l lazy_argsE) + where l = L loc nlTuple exps = ExplicitTuple (map noLoc exps) Boxed srcSpanLit :: SrcSpan -> HsExpr Id srcSpanLit span = HsLit (HsString (mkFastString (showSDoc (ppr span)))) instrumenting = idName bkptFuncId == breakpointAutoName + mkTupleType tys = mkTupleTy Boxed (length tys) tys #else mkBreakpointExpr = undefined -- A stage1 ghc doesn't care about breakpoints #endif @@ -139,14 +141,12 @@ mkJumpFunc bkptFuncId where tyvar = alphaTyVar basicType extra opaqueTy = - (FunTy intTy - (FunTy (mkListTy opaqueTy) - (FunTy (mkTupleType [stringTy, stringTy, intTy]) - (FunTy stringTy + (FunTy (mkTupleType [stringTy, intTy]) + (FunTy (mkTupleType [intTy, mkListTy opaqueTy, stringTy]) (ForAllTy tyvar (extra (FunTy (TyVarTy tyvar) - (TyVarTy tyvar)))))))) + (TyVarTy tyvar)))))) build name extra = do ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName return$ Id.mkGlobalId VanillaGlobal name diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs index d3dd0e1..9251a81 100644 --- a/compiler/deSugar/DsMonad.lhs +++ b/compiler/deSugar/DsMonad.lhs @@ -23,7 +23,7 @@ module DsMonad ( DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv, - bindLocalsDs, getLocalBindsDs, getBkptSitesDs, + bindLocalsDs, getLocalBindsDs, getBkptSitesDs, getModNameRefDs, withModNameRefDs, -- Warnings DsWarning, warnDs, failWithDs, @@ -144,7 +144,9 @@ data DsGblEnv = DsGblEnv { data DsLclEnv = DsLclEnv { ds_meta :: DsMetaEnv, -- Template Haskell bindings ds_loc :: SrcSpan, -- to put in pattern-matching error msgs - ds_locals :: OccEnv Id -- For locals in breakpoints + ds_locals :: OccEnv Id, -- For locals in breakpoints + ds_mod_name_ref :: Maybe Id -- The Id used to store the Module name + -- used by the breakpoint desugaring } -- Inside [| |] brackets, the desugarer looks @@ -211,7 +213,8 @@ mkDsEnvs mod rdr_env type_env msg_var ds_bkptSites = sites_var} lcl_env = DsLclEnv { ds_meta = emptyNameEnv, ds_loc = noSrcSpan, - ds_locals = emptyOccEnv } + ds_locals = emptyOccEnv, + ds_mod_name_ref = Nothing } return (gbl_env, lcl_env) @@ -337,6 +340,13 @@ dsExtendMetaEnv menv thing_inside getLocalBindsDs :: DsM [Id] getLocalBindsDs = do { env <- getLclEnv; return (occEnvElts$ ds_locals env) } +getModNameRefDs :: DsM (Maybe Id) +getModNameRefDs = do { env <- getLclEnv; return (ds_mod_name_ref env) } + +withModNameRefDs :: Id -> DsM a -> DsM a +withModNameRefDs id thing_inside = + updLclEnv (\env -> env {ds_mod_name_ref = Just id}) thing_inside + bindLocalsDs :: [Id] -> DsM a -> DsM a bindLocalsDs new_ids enclosed_scope = updLclEnv (\env-> env {ds_locals = ds_locals env `extendOccEnvList` occnamed_ids}) diff --git a/compiler/main/Breakpoints.hs b/compiler/main/Breakpoints.hs index fccf1a8..c4318ca 100644 --- a/compiler/main/Breakpoints.hs +++ b/compiler/main/Breakpoints.hs @@ -46,9 +46,9 @@ noDbgSites = [] #ifdef GHCI lookupBogusBreakpointVal :: Name -> Maybe HValue lookupBogusBreakpointVal name - | name == breakpointJumpName = Just$ unsafeCoerce# (\_ _ _ _ a->a) - | name == breakpointAutoJumpName = Just$ unsafeCoerce# (\_ _ _ _ a->a) - | name == breakpointCondJumpName = Just$ unsafeCoerce# (\_ _ _ _ _ a->a) + | name == breakpointJumpName = Just$ unsafeCoerce# (\_ _ a->a) + | name == breakpointAutoJumpName = Just$ unsafeCoerce# (\_ _ a->a) + | name == breakpointCondJumpName = Just$ unsafeCoerce# (\_ _ _ a->a) | otherwise = Nothing #else lookupBogusBreakpointVal _ = Nothing diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 52212d6..2167035 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -255,7 +255,7 @@ import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept, cleanTempDirs ) import Module import UniqFM -import PackageConfig ( PackageId, stringToPackageId ) +import PackageConfig ( PackageId, stringToPackageId, mainPackageId ) import FiniteMap import Panic import Digraph @@ -2258,44 +2258,41 @@ reinstallBreakpointHandlers session = do ----------------------------------------------------------------------- -- Jump functions -type SiteInfo = (String, String, SiteNumber) -jumpFunction, jumpAutoFunction :: Session -> BkptHandler Module -> Int -> [Opaque] - -> SiteInfo -> String -> b -> b -jumpCondFunction :: Session -> BkptHandler Module -> Int -> [Opaque] - -> SiteInfo -> String -> Bool -> b -> b -jumpFunctionM :: Session -> BkptHandler a -> Int -> [Opaque] -> BkptLocation a - -> String -> b -> IO b +type SiteInfo = (String, SiteNumber) +jumpFunction, jumpAutoFunction :: Session -> BkptHandler Module -> SiteInfo -> (Int, [Opaque], String) -> b -> b +jumpCondFunction :: Session -> BkptHandler Module -> SiteInfo -> (Int, [Opaque], String) -> Bool -> b -> b +jumpFunctionM :: Session -> BkptHandler a -> BkptLocation a -> (Int, [Opaque], String) -> b -> IO b -jumpCondFunction _ _ _ _ _ _ False b = b -jumpCondFunction session handler ptr hValues siteInfo locmsg True b - = jumpFunction session handler ptr hValues siteInfo locmsg b +jumpCondFunction _ _ _ _ False b = b +jumpCondFunction session handler site args True b + = jumpFunction session handler site args b -jumpFunction session handler ptr hValues siteInfo locmsg b +jumpFunction session handler siteInfo args b | site <- mkSite siteInfo - = unsafePerformIO $ jumpFunctionM session handler ptr hValues site locmsg b + = unsafePerformIO $ jumpFunctionM session handler site args b -jumpFunctionM session handler (I# idsPtr) wrapped_hValues site locmsg b = +jumpFunctionM session handler site (I# idsPtr, wrapped_hValues, locmsg) b = do ids <- deRefStablePtr (castPtrToStablePtr (Ptr (int2Addr# idsPtr))) let hValues = unsafeCoerce# b : [unsafeCoerce# hv | O hv <- wrapped_hValues] handleBreakpoint handler session (zip ids hValues) site locmsg b -jumpAutoFunction session handler ptr hValues siteInfo locmsg b +jumpAutoFunction session handler siteInfo args b | site <- mkSite siteInfo = unsafePerformIO $ do break <- isAutoBkptEnabled handler session site if break - then jumpFunctionM session handler ptr hValues site locmsg b + then jumpFunctionM session handler site args b else return b -jumpStepByStepFunction session handler ptr hValues siteInfo locmsg b +jumpStepByStepFunction session handler siteInfo args b | site <- mkSite siteInfo = unsafePerformIO $ do - jumpFunctionM session handler ptr hValues site locmsg b + jumpFunctionM session handler site args b mkSite :: SiteInfo -> BkptLocation Module -mkSite (pkgName, modName, sitenum) = - (mkModule (stringToPackageId pkgName) (mkModuleName modName), sitenum) +mkSite ( modName, sitenum) = + (mkModule mainPackageId (mkModuleName modName), sitenum) obtainTerm1 :: Session -> Bool -> Maybe Type -> a -> IO Term obtainTerm1 sess force mb_ty x = withSession sess $ \hsc_env -> cvObtainTerm hsc_env force mb_ty (unsafeCoerce# x)