X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsBreakpoint.lhs;h=869cde64b24eacae90d721c4d51d29f4701cf0f0;hb=7e03b5b7cfd72c651444856fe83b429da0734ec2;hp=f6c7d9e28bec18a6205f3936a5e9a4f98598a56a;hpb=989cfb23660ecefe7e414a1ca1f3004e820ef50b;p=ghc-hetmet.git diff --git a/compiler/deSugar/DsBreakpoint.lhs b/compiler/deSugar/DsBreakpoint.lhs index f6c7d9e..869cde6 100644 --- a/compiler/deSugar/DsBreakpoint.lhs +++ b/compiler/deSugar/DsBreakpoint.lhs @@ -14,121 +14,100 @@ module DsBreakpoint( , mkBreakpointExpr ) where -import IOEnv ( ioToIOEnv ) -import TysPrim ( alphaTyVar ) -import TysWiredIn ( intTy, stringTy, mkTupleTy, mkListTy, boolTy ) +import TysPrim +import TysWiredIn import PrelNames -import Module ( moduleName, moduleNameFS, modulePackageId ) -import PackageConfig ( packageIdFS) -import SrcLoc ( SrcLoc, Located(..), SrcSpan, srcSpanFile, - noLoc, noSrcLoc, isGoodSrcSpan, - srcLocLine, srcLocCol, srcSpanStart ) - -import TyCon ( isUnLiftedTyCon, tyConDataCons ) -import TypeRep ( Type(..) ) +import Module +import PackageConfig +import SrcLoc +import TyCon +import TypeRep import DataCon import Type -import MkId ( unsafeCoerceId, lazyId ) -import Name ( Name, mkInternalName ) -import Var ( mkTyVar ) -import Id ( Id, idType, mkGlobalId, idName ) +import Id -import IdInfo ( vanillaIdInfo, GlobalIdDetails (VanillaGlobal) ) -import BasicTypes ( Boxity(Boxed) ) -import OccName ( mkOccName, tvName ) +import IdInfo +import BasicTypes +import OccName import TcRnMonad import HsSyn -import HsLit ( HsLit(HsString, HsInt) ) -import CoreSyn ( CoreExpr, Expr (App) ) -import CoreUtils ( exprType ) +import HsLit +import CoreSyn +import CoreUtils import Outputable -import ErrUtils ( debugTraceMsg ) -import FastString ( mkFastString, unpackFS ) -import DynFlags ( GhcMode(..), DynFlag(Opt_Debugging, Opt_IgnoreBreakpoints) ) +import ErrUtils +import FastString +import DynFlags import DsMonad import {-#SOURCE#-}DsExpr ( dsLExpr ) import Control.Monad import Data.IORef -import Foreign.StablePtr ( newStablePtr, castStablePtrToPtr ) -import GHC.Exts ( Ptr(..), Int(..), addr2Int#, unsafeCoerce# ) - -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) $ +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 + 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 +#else +mkBreakpointExpr = undefined -- A stage1 ghc doesn't care about breakpoints +#endif -debug_enabled :: DsM Bool -debug_enabled = do - debugging <- doptDs Opt_Debugging - b_enabled <- breakpoints_enabled - return (debugging && b_enabled) - -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 {} = True -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 = mkGlobalId VanillaGlobal breakpointAutoName + let autoBreakpoint = Id.mkGlobalId VanillaGlobal breakpointAutoName breakpointAutoTy vanillaIdInfo dflags <- getDOptsDs ioToIOEnv$ debugTraceMsg dflags 3 (text "Breakpoint inserted at " <> ppr loc) @@ -139,7 +118,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 @@ -169,43 +147,68 @@ mkJumpFunc bkptFuncId (TyVarTy tyvar)))))))) build name extra = do ATyCon opaqueTyCon <- dsLookupGlobal opaqueTyConName - return$ mkGlobalId VanillaGlobal name + 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 + ignore_breakpoints <- doptDs Opt_IgnoreBreakpoints + return ( not ignore_breakpoints + && ghcMode == Interactive + && 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}