X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsBreakpoint.lhs;h=c6a090e2301d8ebb4eb8e35b866df75d6da74489;hp=1abfb0caba86228ec9b15d1397d908b89080717a;hb=dc8ffcb9797ade3e3a68e6ec0a89fe2e7444e0ef;hpb=3a99fa889bdff0c86df20cb18c71d30e30a79b43 diff --git a/compiler/deSugar/DsBreakpoint.lhs b/compiler/deSugar/DsBreakpoint.lhs index 1abfb0c..c6a090e 100644 --- a/compiler/deSugar/DsBreakpoint.lhs +++ b/compiler/deSugar/DsBreakpoint.lhs @@ -7,102 +7,128 @@ ----------------------------------------------------------------------------- \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 + +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: bad SrcSpan" (ppr loc) +#endif +dynBreakpoint loc = do + let autoBreakpoint = Id.mkGlobalId VanillaGlobal breakpointAutoName + breakpointAutoTy vanillaIdInfo + dflags <- getDOptsDs + ioToIOEnv$ debugTraceMsg dflags 3 (text "Breakpoint inserted at " <> ppr loc) + return$ L loc (HsVar autoBreakpoint) + where breakpointAutoTy = (ForAllTy alphaTyVar + (FunTy (TyVarTy alphaTyVar) + (TyVarTy alphaTyVar))) + +-- Records a breakpoint site and returns the site number +recordBkpt :: SrcLoc -> DsM (Int) +recordBkpt loc = do + sites_var <- getBkptSitesDs + sites <- ioToIOEnv$ readIORef sites_var + let site = length sites + 1 + let coords = (srcLocLine loc, srcLocCol loc) + ioToIOEnv$ writeIORef sites_var ((site, coords) : sites) + return site mkJumpFunc :: Id -> DsM Id mkJumpFunc bkptFuncId @@ -115,19 +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 = 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}