X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsBreakpoint.lhs;h=c6a090e2301d8ebb4eb8e35b866df75d6da74489;hp=eac7e4845cda37851847e2115e5dff83d61d1fe8;hb=dc8ffcb9797ade3e3a68e6ec0a89fe2e7444e0ef;hpb=8894145751d8c7841b25e3fe561b42f65982d057 diff --git a/compiler/deSugar/DsBreakpoint.lhs b/compiler/deSugar/DsBreakpoint.lhs index eac7e48..c6a090e 100644 --- a/compiler/deSugar/DsBreakpoint.lhs +++ b/compiler/deSugar/DsBreakpoint.lhs @@ -7,27 +7,22 @@ ----------------------------------------------------------------------------- \begin{code} -module DsBreakpoint( - dsAndThenMaybeInsertBreakpoint +module DsBreakpoint( debug_enabled + , dsAndThenMaybeInsertBreakpoint , maybeInsertBreakpoint , breakpoints_enabled , mkBreakpointExpr ) where -import IOEnv import TysPrim import TysWiredIn import PrelNames import Module -import PackageConfig import SrcLoc import TyCon import TypeRep import DataCon import Type -import MkId -import Name -import Var import Id import IdInfo @@ -43,6 +38,7 @@ import Outputable import ErrUtils import FastString import DynFlags +import MkId import DsMonad import {-#SOURCE#-}DsExpr ( dsLExpr ) @@ -52,86 +48,68 @@ import Foreign.StablePtr import GHC.Exts #ifdef GHCI -mkBreakpointExpr :: SrcSpan -> Id -> DsM (LHsExpr Id) -mkBreakpointExpr loc bkptFuncId = do - scope' <- getLocalBindsDs - mod <- getModuleDs - let scope = filter (isValidType .idType ) scope' - mod_name = moduleNameFS$ moduleName mod - if null scope && instrumenting - then return (l$ HsVar lazyId) - else do - when (not instrumenting) $ +mkBreakpointExpr :: SrcSpan -> Id -> Type -> DsM (LHsExpr Id) +mkBreakpointExpr loc bkptFuncId ty = do + scope <- getScope + mod <- getModuleDs + u <- newUnique + let valId = mkUserLocal (mkVarOcc "_result") u ty noSrcLoc + when (not instrumenting) $ warnDs (text "Extracted ids:" <+> (ppr scope $$ ppr (map idType scope))) - stablePtr <- ioToIOEnv $ newStablePtr scope - site <- if instrumenting - then recordBkpt (srcSpanStart loc) - else return 0 - ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName - jumpFuncId <- mkJumpFunc bkptFuncId - let [opaqueDataCon] = tyConDataCons opaqueTyCon - opaqueId = dataConWrapId opaqueDataCon - opaqueTy = mkTyConApp opaqueTyCon [] - wrapInOpaque id = + stablePtr <- ioToIOEnv $ newStablePtr (valId:scope) + site <- if instrumenting + then recordBkpt (srcSpanStart loc) + 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 [] + wrapInOpaque id = l(HsApp (l(HsWrap (WpTyApp (idType id)) (HsVar opaqueId))) (l(HsVar id))) -- Yes, I know... I'm gonna burn in hell. - Ptr addr# = castStablePtrToPtr stablePtr - hvals = ExplicitList opaqueTy (map wrapInOpaque scope) - locInfo = nlTuple [ HsLit (HsString (packageIdFS$ modulePackageId mod)) - , HsLit (HsString mod_name) - , HsLit (HsInt (fromIntegral site))] - - funE = l$ HsVar jumpFuncId - ptrE = l (HsLit (HsInt (fromIntegral (I# (addr2Int# addr#))))) - hvalE = l hvals - locE = l locInfo - msgE = l (srcSpanLit loc) - return$ l(l(l(l(funE `HsApp` ptrE) `HsApp` hvalE) `HsApp` locE) `HsApp` msgE) + Ptr addr# = castStablePtrToPtr stablePtr + locals = ExplicitList opaqueTy (map wrapInOpaque scope) + locInfo = nlTuple [ HsVar mod_name_ref + , HsLit (HsInt (fromIntegral site))] + funE = l$ HsVar jumpFuncId + 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 --- isValidType (PredTy p `FunTy` ty ) = False -- TODO: Too restrictive ? - isValidType (FunTy a b) = isValidType a && isValidType b - isValidType (NoteTy _ t) = isValidType t - isValidType (AppTy a b) = isValidType a && isValidType b - isValidType (TyConApp con ts) = not (isUnLiftedTyCon con) && all isValidType ts - isValidType _ = True 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 -debug_enabled :: DsM Bool -#if defined(GHCI) && defined(DEBUGGER) -debug_enabled = do - debugging <- doptDs Opt_Debugging - b_enabled <- breakpoints_enabled - return (debugging && b_enabled) -#else -debug_enabled = return False -#endif - -maybeInsertBreakpoint :: LHsExpr Id -> Type -> DsM (LHsExpr Id) ---maybeInsertBreakpoint e | pprTrace("insertBreakpoint at" (ppr e) False = undefined - -isInstrumentationSpot (L loc e) = do - ghcmode <- getGhcModeDs - instrumenting <- debug_enabled - return$ instrumenting - && isGoodSrcSpan loc -- Avoids 'derived' code - && (not$ isRedundant e) - -isRedundant HsLet {} = True -isRedundant HsDo {} = True -isRedundant HsCase {} = False -isRedundant _ = False +getScope :: DsM [Id] +getScope = getLocalBindsDs >>= return . filter(isValidType .idType ) + where isValidType (FunTy a b) = isValidType a && isValidType b + isValidType (NoteTy _ t) = isValidType t + isValidType (AppTy a b) = isValidType a && isValidType b + isValidType (TyConApp con ts) = not (isUnLiftedTyCon con) && + all isValidType ts +-- isValidType (PredTy p `FunTy` ty ) = False -- TODO: Too restrictive ? + isValidType _ = True dynBreakpoint :: SrcSpan -> DsM (LHsExpr Id) +#ifdef DEBUG dynBreakpoint loc | not (isGoodSrcSpan loc) = - pprPanic "dynBreakpoint" (ppr loc) + pprPanic "dynBreakpoint: bad SrcSpan" (ppr loc) +#endif dynBreakpoint loc = do let autoBreakpoint = Id.mkGlobalId VanillaGlobal breakpointAutoName breakpointAutoTy vanillaIdInfo @@ -144,7 +122,6 @@ dynBreakpoint loc = do -- Records a breakpoint site and returns the site number recordBkpt :: SrcLoc -> DsM (Int) ---recordBkpt | trace "recordBkpt" False = undefined recordBkpt loc = do sites_var <- getBkptSitesDs sites <- ioToIOEnv$ readIORef sites_var @@ -164,53 +141,77 @@ 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 (basicType extra (mkTyConApp opaqueTyCon [])) vanillaIdInfo mkTupleType tys = mkTupleTy Boxed (length tys) tys -breakpoints_enabled :: DsM Bool +debug_enabled, breakpoints_enabled :: DsM Bool dsAndThenMaybeInsertBreakpoint :: LHsExpr Id -> DsM CoreExpr +maybeInsertBreakpoint :: LHsExpr Id -> Type -> DsM (LHsExpr Id) + +#if defined(GHCI) && defined(DEBUGGER) +debug_enabled = do + debugging <- doptDs Opt_Debugging + b_enabled <- breakpoints_enabled + return (debugging && b_enabled) + +breakpoints_enabled = do + ghcMode <- getGhcModeDs + currentModule <- getModuleDs + dflags <- getDOptsDs + ignore_breakpoints <- doptDs Opt_IgnoreBreakpoints + return ( not ignore_breakpoints + && hscTarget dflags == HscInterpreted + && currentModule /= iNTERACTIVE ) -#ifdef GHCI maybeInsertBreakpoint lhsexpr@(L loc _) ty = do instrumenting <- isInstrumentationSpot lhsexpr - if instrumenting + scope <- getScope + if instrumenting && not(isUnLiftedType ty) && + not(isEnabledNullScopeCoalescing && null scope) then do L _ dynBkpt <- dynBreakpoint loc --- return (l (HsApp (l$ TyApp dynBkpt [ty]) lhsexpr)) return$ l(HsApp (l$ HsWrap (WpTyApp ty) dynBkpt) lhsexpr) else return lhsexpr where l = L loc - dsAndThenMaybeInsertBreakpoint expr@(L loc _) = do - coreExpr <- dsLExpr expr + coreExpr <- dsLExpr expr instrumenting <- isInstrumentationSpot expr - if instrumenting + scope <- getScope + let ty = exprType coreExpr + if instrumenting && not (isUnLiftedType (exprType coreExpr)) && + not(isEnabledNullScopeCoalescing && null scope) then do L _ dynBkpt<- dynBreakpoint loc - bkptCore <- dsLExpr (l$ HsWrap (WpTyApp (exprType coreExpr)) dynBkpt) + bkptCore <- dsLExpr (l$ HsWrap (WpTyApp ty) dynBkpt) return (bkptCore `App` coreExpr) else return coreExpr where l = L loc - -breakpoints_enabled = do - ghcMode <- getGhcModeDs - currentModule <- getModuleDs - ignore_breakpoints <- doptDs Opt_IgnoreBreakpoints - return ( not ignore_breakpoints - && ghcMode == Interactive - && currentModule /= iNTERACTIVE ) #else maybeInsertBreakpoint expr _ = return expr dsAndThenMaybeInsertBreakpoint coreExpr = dsLExpr coreExpr breakpoints_enabled = return False +debug_enabled = return False #endif + + +isInstrumentationSpot (L loc e) = do + ghcmode <- getGhcModeDs + instrumenting <- debug_enabled + return$ instrumenting + && isGoodSrcSpan loc -- Avoids 'derived' code + && (not$ isRedundant e) + +isEnabledNullScopeCoalescing = True +isRedundant HsLet {} = True +isRedundant HsDo {} = True +isRedundant HsCase {} = False +isRedundant _ = False + \end{code}