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 DsMonad
import DsGRHSs
import DsUtils
import HsSyn -- lots of things
import CoreSyn -- lots of things
import HsSyn -- lots of things
import CoreSyn -- lots of things
import FastString
import Util ( mapSnd )
import FastString
import Util ( mapSnd )
+import Name
+import OccName
+import Literal
+
import Control.Monad
import Data.List
\end{code}
import Control.Monad
import Data.List
\end{code}
\begin{code}
dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
\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
dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
dsLHsBinds binds = ds_lhs_binds NoSccs binds
-----------------------------------------------------------------------------
\begin{code}
-----------------------------------------------------------------------------
\begin{code}
-module DsBreakpoint(
- dsAndThenMaybeInsertBreakpoint
+module DsBreakpoint( debug_enabled
+ , dsAndThenMaybeInsertBreakpoint
, maybeInsertBreakpoint
, breakpoints_enabled
, mkBreakpointExpr
, maybeInsertBreakpoint
, breakpoints_enabled
, mkBreakpointExpr
import TysWiredIn
import PrelNames
import Module
import TysWiredIn
import PrelNames
import Module
import SrcLoc
import TyCon
import TypeRep
import SrcLoc
import TyCon
import TypeRep
import Data.IORef
import Foreign.StablePtr
import GHC.Exts
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
#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)))
when (not instrumenting) $
warnDs (text "Extracted ids:" <+> (ppr scope $$
ppr (map idType scope)))
else return 0
ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName
jumpFuncId <- mkJumpFunc bkptFuncId
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 []
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)
-- 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
, 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
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
#else
mkBreakpointExpr = undefined -- A stage1 ghc doesn't care about breakpoints
#endif
where
tyvar = alphaTyVar
basicType extra opaqueTy =
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)
(ForAllTy tyvar
(extra
(FunTy (TyVarTy tyvar)
build name extra = do
ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName
return$ Id.mkGlobalId VanillaGlobal name
build name extra = do
ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName
return$ Id.mkGlobalId VanillaGlobal name
DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
- bindLocalsDs, getLocalBindsDs, getBkptSitesDs,
+ bindLocalsDs, getLocalBindsDs, getBkptSitesDs, getModNameRefDs, withModNameRefDs,
-- Warnings
DsWarning, warnDs, failWithDs,
-- Warnings
DsWarning, warnDs, failWithDs,
data DsLclEnv = DsLclEnv {
ds_meta :: DsMetaEnv, -- Template Haskell bindings
ds_loc :: SrcSpan, -- to put in pattern-matching error msgs
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
}
-- Inside [| |] brackets, the desugarer looks
ds_bkptSites = sites_var}
lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
ds_loc = noSrcSpan,
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)
return (gbl_env, lcl_env)
getLocalBindsDs :: DsM [Id]
getLocalBindsDs = do { env <- getLclEnv; return (occEnvElts$ ds_locals 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})
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
#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
| otherwise = Nothing\r
#else \r
lookupBogusBreakpointVal _ = Nothing\r
cleanTempDirs )
import Module
import UniqFM
cleanTempDirs )
import Module
import UniqFM
-import PackageConfig ( PackageId, stringToPackageId )
+import PackageConfig ( PackageId, stringToPackageId, mainPackageId )
import FiniteMap
import Panic
import Digraph
import FiniteMap
import Panic
import Digraph
-----------------------------------------------------------------------
-- Jump functions
-----------------------------------------------------------------------
-- 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
| 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
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
| 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
-jumpStepByStepFunction session handler ptr hValues siteInfo locmsg b
+jumpStepByStepFunction session handler siteInfo args b
| site <- mkSite siteInfo
= unsafePerformIO $ do
| site <- mkSite siteInfo
= unsafePerformIO $ do
- jumpFunctionM session handler ptr hValues site locmsg b
+ jumpFunctionM session handler site args b
mkSite :: SiteInfo -> BkptLocation Module
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)
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)