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).
import DsMonad
import DsGRHSs
import DsUtils
+import DsBreakpoint
import HsSyn -- lots of things
import CoreSyn -- lots of things
import FastString
import Util ( mapSnd )
+import Name
+import OccName
+import Literal
+
import Control.Monad
import Data.List
\end{code}
\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
-----------------------------------------------------------------------------
\begin{code}
-module DsBreakpoint(
- dsAndThenMaybeInsertBreakpoint
+module DsBreakpoint( debug_enabled
+ , dsAndThenMaybeInsertBreakpoint
, maybeInsertBreakpoint
, breakpoints_enabled
, mkBreakpointExpr
import TysWiredIn
import PrelNames
import Module
-import PackageConfig
import SrcLoc
import TyCon
import TypeRep
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)))
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 []
-- 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
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
DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
- bindLocalsDs, getLocalBindsDs, getBkptSitesDs,
+ bindLocalsDs, getLocalBindsDs, getBkptSitesDs, getModNameRefDs, withModNameRefDs,
-- Warnings
DsWarning, warnDs, failWithDs,
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
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)
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})
#ifdef GHCI\r
lookupBogusBreakpointVal :: Name -> Maybe HValue\r
lookupBogusBreakpointVal name \r
- | name == breakpointJumpName = Just$ unsafeCoerce# (\_ _ _ _ a->a)\r
- | name == breakpointAutoJumpName = Just$ unsafeCoerce# (\_ _ _ _ a->a)\r
- | name == breakpointCondJumpName = Just$ unsafeCoerce# (\_ _ _ _ _ a->a)\r
+ | name == breakpointJumpName = Just$ unsafeCoerce# (\_ _ a->a)\r
+ | name == breakpointAutoJumpName = Just$ unsafeCoerce# (\_ _ a->a)\r
+ | name == breakpointCondJumpName = Just$ unsafeCoerce# (\_ _ _ a->a)\r
| otherwise = Nothing\r
#else \r
lookupBogusBreakpointVal _ = Nothing\r
cleanTempDirs )
import Module
import UniqFM
-import PackageConfig ( PackageId, stringToPackageId )
+import PackageConfig ( PackageId, stringToPackageId, mainPackageId )
import FiniteMap
import Panic
import Digraph
-----------------------------------------------------------------------
-- 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)