From: Pepe Iborra Date: Mon, 11 Dec 2006 16:20:27 +0000 (+0000) Subject: Adjust code from manual merges X-Git-Tag: 2006-12-17~4 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=989cfb23660ecefe7e414a1ca1f3004e820ef50b Adjust code from manual merges --- diff --git a/compiler/deSugar/DsBreakpoint.lhs b/compiler/deSugar/DsBreakpoint.lhs index ed7a536..f6c7d9e 100644 --- a/compiler/deSugar/DsBreakpoint.lhs +++ b/compiler/deSugar/DsBreakpoint.lhs @@ -54,7 +54,6 @@ 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 @@ -110,36 +109,8 @@ debug_enabled = do 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 @@ -202,9 +173,39 @@ mkJumpFunc bkptFuncId (basicType extra (mkTyConApp opaqueTyCon [])) vanillaIdInfo mkTupleType tys = mkTupleTy Boxed (length tys) tys +breakpoints_enabled :: DsM Bool +dsAndThenMaybeInsertBreakpoint :: LHsExpr Id -> DsM CoreExpr + +#ifdef GHCI +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 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 + +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 = False +breakpoints_enabled = return False #endif \end{code} diff --git a/compiler/ghci/ByteCodeLink.lhs-boot b/compiler/ghci/ByteCodeLink.lhs-boot new file mode 100644 index 0000000..2b78c36 --- /dev/null +++ b/compiler/ghci/ByteCodeLink.lhs-boot @@ -0,0 +1,3 @@ +>module ByteCodeLink where +> +>data HValue diff --git a/compiler/ghci/GhciMonad.hs b/compiler/ghci/GhciMonad.hs index 04c5ffa..df588aa 100644 --- a/compiler/ghci/GhciMonad.hs +++ b/compiler/ghci/GhciMonad.hs @@ -140,13 +140,14 @@ handler :: Exception -> GHCi Bool handler (DynException dyn) | Just StopChildSession <- fromDynamic dyn -- propagate to the parent session - = ASSERTM (liftM not isTopLevel) >> throwDyn StopChildSession + = do ASSERTM (liftM not isTopLevel) + throwDyn StopChildSession | Just (ChildSessionStopped msg) <- fromDynamic dyn -- Revert CAFs and display some message - = ASSERTM (isTopLevel) >> - io (revertCAFs >> putStrLn msg) >> - return False + = do ASSERTM (isTopLevel) + io (revertCAFs >> putStrLn msg) + return False handler exception = do flushInterpBuffers @@ -231,7 +232,7 @@ no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++ " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering" flush_cmd = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush System.IO.stderr" -initInterpBuffering :: Session -> IO () +initInterpBuffering :: GHC.Session -> IO () initInterpBuffering session = do maybe_hval <- GHC.compileExpr session no_buf_cmd diff --git a/compiler/main/Breakpoints.hs b/compiler/main/Breakpoints.hs index b1b0118..ecb3c33 100644 --- a/compiler/main/Breakpoints.hs +++ b/compiler/main/Breakpoints.hs @@ -20,6 +20,7 @@ import PrelNames import GHC.Exts ( unsafeCoerce# ) +#ifdef GHCI data BkptHandler a = BkptHandler { handleBreakpoint :: forall b. Session -> [(Id,HValue)] -> BkptLocation a -> String -> b -> IO b , isAutoBkptEnabled :: Session -> BkptLocation a -> IO Bool @@ -29,6 +30,7 @@ nullBkptHandler = BkptHandler { isAutoBkptEnabled = \ _ _ -> return False, handleBreakpoint = \_ _ _ _ b -> putStrLn "null Bkpt Handler" >> return b } +#endif type BkptLocation a = (a, SiteNumber) type SiteNumber = Int diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index a176a73..2bd6816 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -84,9 +84,10 @@ import Util ( split ) import Data.Char ( isDigit, isUpper ) import System.IO ( hPutStrLn, stderr ) +#ifdef GHCI import Breakpoints ( BkptHandler ) import Module ( ModuleName ) - +#endif -- ----------------------------------------------------------------------------- -- DynFlags @@ -308,8 +309,10 @@ data DynFlags = DynFlags { -- message output log_action :: Severity -> SrcSpan -> PprStyle -> Message -> IO () +#ifdef GHCI -- breakpoint handling ,bkptHandler :: Maybe (BkptHandler Module) +#endif } data HscTarget @@ -418,8 +421,9 @@ defaultDynFlags = packageFlags = [], pkgDatabase = Nothing, pkgState = panic "no package state yet: call GHC.setSessionDynFlags", - +#ifdef GHCI bkptHandler = Nothing, +#endif flags = [ Opt_ReadUserPackageConf, diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index ef9fd02..ad52387 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -180,6 +180,7 @@ module GHC ( #include "HsVersions.h" #ifdef GHCI +import RtClosureInspect ( cvObtainTerm, Term ) import TcRnDriver ( tcRnLookupRdrName, tcRnGetInfo, tcRnLookupName, getModuleExports ) import RdrName ( plusGlobalRdrEnv, Provenance(..), @@ -206,7 +207,6 @@ import Data.Maybe ( fromMaybe) import qualified Linker import Data.Dynamic ( Dynamic ) -import RtClosureInspect ( cvObtainTerm, Term ) import Linker ( HValue, getHValue, extendLinkEnv ) #endif @@ -1763,9 +1763,9 @@ data ModuleInfo = ModuleInfo { minf_type_env :: TypeEnv, minf_exports :: NameSet, -- ToDo, [AvailInfo] like ModDetails? minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod - minf_instances :: [Instance], + minf_instances :: [Instance] #ifdef GHCI - minf_dbg_sites :: [(SiteNumber,Coord)] + ,minf_dbg_sites :: [(SiteNumber,Coord)] #endif -- ToDo: this should really contain the ModIface too } diff --git a/compiler/typecheck/TcEnv.lhs-boot b/compiler/typecheck/TcEnv.lhs-boot new file mode 100644 index 0000000..4f25cee --- /dev/null +++ b/compiler/typecheck/TcEnv.lhs-boot @@ -0,0 +1,4 @@ +>module TcEnv where +>import TcRnTypes +> +>tcExtendIdEnv :: [TcId] -> TcM a -> TcM a \ No newline at end of file diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 044b67d..156b52f 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -69,8 +69,8 @@ import NameSet import TyCon import SrcLoc import HscTypes -import DsBreakpoint import Outputable +import Breakpoints #ifdef GHCI import Linker diff --git a/rts/Linker.c b/rts/Linker.c index 45f5ff6..f1ec48a 100644 --- a/rts/Linker.c +++ b/rts/Linker.c @@ -817,6 +817,7 @@ static RtsSymbolVal rtsSyms[] = { /* ----------------------------------------------------------------------------- * Insert symbols into hash tables, checking for duplicates. */ +int isSuffixOf(char* x, char* suffix); static void ghciInsertStrHashTable ( char* obj_name, HashTable *table, @@ -856,17 +857,6 @@ static void ghciInsertStrHashTable ( char* obj_name, ); exit(1); } - -#if defined(GHCI) && defined(BREAKPOINT) -static void ghciInsertDCTable ( char* obj_name, - StgWord key, - char* data - ) -{ - ghciInsertStrHashTable(obj_name, dchash, (char *)key, data); - -} -#endif /* ----------------------------------------------------------------------------- * initialize the object linker */