Commit 2bbec92e authored by mnislaih's avatar mnislaih

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).
parent 1c7caf1c
......@@ -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
......
......@@ -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
......
......@@ -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})
......
......@@ -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
......
......@@ -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)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment