X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsBreakpoint.lhs;h=c6a090e2301d8ebb4eb8e35b866df75d6da74489;hp=ed7a53680e1a727f0ba99dc87d8e6487b93688ac;hb=dc8ffcb9797ade3e3a68e6ec0a89fe2e7444e0ef;hpb=376101055fb111ebd52b5ef1fb76e00334b44304 diff --git a/compiler/deSugar/DsBreakpoint.lhs b/compiler/deSugar/DsBreakpoint.lhs index ed7a536..c6a090e 100644 --- a/compiler/deSugar/DsBreakpoint.lhs +++ b/compiler/deSugar/DsBreakpoint.lhs @@ -7,157 +7,111 @@ ----------------------------------------------------------------------------- \begin{code} -module DsBreakpoint( - dsAndThenMaybeInsertBreakpoint +module DsBreakpoint( debug_enabled + , dsAndThenMaybeInsertBreakpoint , maybeInsertBreakpoint , breakpoints_enabled , 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 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 MkId import DsMonad import {-#SOURCE#-}DsExpr ( dsLExpr ) import Control.Monad import Data.IORef -import Foreign.StablePtr ( newStablePtr, castStablePtrToPtr ) -import GHC.Exts ( Ptr(..), Int(..), addr2Int#, unsafeCoerce# ) - -#if defined(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) $ +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 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 -debug_enabled = do - debugging <- doptDs Opt_Debugging - b_enabled <- breakpoints_enabled - return (debugging && b_enabled) - -breakpoints_enabled :: DsM Bool -breakpoints_enabled = do - ghcMode <- getGhcModeDs - currentModule <- getModuleDs - ignore_breakpoints <- doptDs Opt_IgnoreBreakpoints - return ( not ignore_breakpoints - && ghcMode == Interactive - && currentModule /= iNTERACTIVE ) - -maybeInsertBreakpoint :: LHsExpr Id -> Type -> DsM (LHsExpr Id) ---maybeInsertBreakpoint e | pprTrace("insertBreakpoint at" (ppr e) False = undefined -maybeInsertBreakpoint lhsexpr@(L loc _) ty = do - instrumenting <- isInstrumentationSpot lhsexpr - if instrumenting - 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 :: LHsExpr Id -> DsM CoreExpr -dsAndThenMaybeInsertBreakpoint expr@(L loc _) = do - coreExpr <- dsLExpr expr - instrumenting <- isInstrumentationSpot expr - if instrumenting - then do L _ dynBkpt<- dynBreakpoint loc - bkptCore <- dsLExpr (l$ HsWrap (WpTyApp (exprType coreExpr)) dynBkpt) - return (bkptCore `App` coreExpr) - else return coreExpr - where l = L loc - -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) @@ -168,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 @@ -188,23 +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$ mkGlobalId VanillaGlobal name + return$ Id.mkGlobalId VanillaGlobal name (basicType extra (mkTyConApp opaqueTyCon [])) vanillaIdInfo mkTupleType tys = mkTupleTy Boxed (length tys) tys +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 ) + +maybeInsertBreakpoint lhsexpr@(L loc _) ty = do + instrumenting <- isInstrumentationSpot lhsexpr + 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 + instrumenting <- isInstrumentationSpot expr + 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 ty) dynBkpt) + return (bkptCore `App` coreExpr) + else return coreExpr + where l = L loc #else maybeInsertBreakpoint expr _ = return expr dsAndThenMaybeInsertBreakpoint coreExpr = dsLExpr coreExpr -breakpoints_enabled = False +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}