X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsBreakpoint.lhs;h=869cde64b24eacae90d721c4d51d29f4701cf0f0;hb=7f1bc015a4094a8282ad4090768d780fd4d6122d;hp=1d17c97aa4b86e09340ae09d7fe94f09ea086bf8;hpb=848d28cc8df29b3ff10529dcfbc4596355935c84;p=ghc-hetmet.git diff --git a/compiler/deSugar/DsBreakpoint.lhs b/compiler/deSugar/DsBreakpoint.lhs index 1d17c97..869cde6 100644 --- a/compiler/deSugar/DsBreakpoint.lhs +++ b/compiler/deSugar/DsBreakpoint.lhs @@ -14,7 +14,6 @@ module DsBreakpoint( , mkBreakpointExpr ) where -import IOEnv import TysPrim import TysWiredIn import PrelNames @@ -25,9 +24,6 @@ import TyCon import TypeRep import DataCon import Type -import MkId -import Name -import Var import Id import IdInfo @@ -50,54 +46,44 @@ import Control.Monad import Data.IORef 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 - -- need to return some expresion, hence lazy is used here as a noop (hopefully) - 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 mod_name = moduleNameFS$ moduleName mod + 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 + 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 [ 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#))))) + locsE = l locals + locE = l locInfo + msgE = l (srcSpanLit loc) + return $ + l(l(l(l(funE `HsApp` ptrE) `HsApp` locsE) `HsApp` locE) `HsApp` msgE) 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 @@ -105,31 +91,21 @@ mkBreakpointExpr loc bkptFuncId = do 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 - -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 @@ -175,40 +151,64 @@ mkJumpFunc bkptFuncId (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 --- | Takes an expression and its type maybeInsertBreakpoint :: LHsExpr Id -> Type -> DsM (LHsExpr Id) -#ifdef GHCI +#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 + ignore_breakpoints <- doptDs Opt_IgnoreBreakpoints + return ( not ignore_breakpoints + && ghcMode == Interactive + && currentModule /= iNTERACTIVE ) + 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$ 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}