X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FInteractiveEval.hs;h=3f932dcbbfbd1c0576dd363cca627b7c8910b670;hb=0cbdc7b1bd76c61ad31a14a43398ae05ce138489;hp=50eae9f9977741267151d9ce049bf5dcf2be3acf;hpb=8f0034600a8a5fa507994646f96e63e2933a5330;p=ghc-hetmet.git diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 50eae9f..3f932dc 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -9,7 +9,7 @@ module InteractiveEval ( #ifdef GHCI RunResult(..), Status(..), Resume(..), History(..), - runStmt, SingleStep(..), + runStmt, parseImportDecl, SingleStep(..), resume, abandon, abandonAll, getResumeContext, @@ -18,7 +18,7 @@ module InteractiveEval ( getHistoryModule, back, forward, setContext, getContext, - nameSetToGlobalRdrEnv, + availsToGlobalRdrEnv, getNamesInScope, getRdrNamesInScope, moduleIsInterpreted, @@ -29,7 +29,6 @@ module InteractiveEval ( showModule, isModuleInterpreted, compileExpr, dynCompileExpr, - lookupName, Term(..), obtainTermFromId, obtainTermFromVal, reconstructType, skolemiseSubst, skolemiseTy #endif @@ -40,16 +39,20 @@ module InteractiveEval ( #include "HsVersions.h" import HscMain hiding (compileExpr) +import HsSyn (ImportDecl) import HscTypes import TcRnDriver -import Type hiding (typeKind) -import TcType hiding (typeKind) +import TcRnMonad (initTc) +import RnNames (gresFromAvails, rnImports) import InstEnv +import Type +import TcType hiding( typeKind ) import Var import Id import Name hiding ( varName ) import NameSet import RdrName +import PrelNames (pRELUDE) import VarSet import VarEnv import ByteCodeInstr @@ -59,7 +62,7 @@ import Unique import UniqSupply import Module import Panic -import LazyUniqFM +import UniqFM import Maybes import ErrUtils import Util @@ -73,7 +76,7 @@ import MonadUtils import System.Directory import Data.Dynamic -import Data.List (find) +import Data.List (find, partition) import Control.Monad import Foreign import Foreign.C @@ -82,7 +85,7 @@ import Data.Array import Exception import Control.Concurrent import Data.List (sortBy) -import Foreign.StablePtr +-- import Foreign.StablePtr import System.IO -- ----------------------------------------------------------------------------- @@ -250,6 +253,8 @@ withVirtualCWD m = do gbracket set_cwd reset_cwd $ \_ -> m +parseImportDecl :: GhcMonad m => String -> m (ImportDecl RdrName) +parseImportDecl expr = withSession $ \hsc_env -> hscImport hsc_env expr emptyHistory :: BoundedList History emptyHistory = nilBL 50 -- keep a log of length 50 @@ -308,7 +313,7 @@ traceRunStatus expr bindings final_ids let history' = mkHistory hsc_env apStack info `consBL` history -- probably better make history strict here, otherwise -- our BoundedList will be pointless. - liftIO $ evaluate history' + _ <- liftIO $ evaluate history' status <- withBreakAction True (hsc_dflags hsc_env) breakMVar statusMVar $ do @@ -353,13 +358,13 @@ foreign import ccall "&rts_breakpoint_io_action" -- is not responding". -- -- Careful here: there may be ^C exceptions flying around, so we start the new --- thread blocked (forkIO inherits block from the parent, #1048), and unblock +-- thread blocked (forkIO inherits mask from the parent, #1048), and unblock -- only while we execute the user's code. We can't afford to lose the final -- putMVar, otherwise deadlock ensues. (#1583, #1922, #1946) sandboxIO :: DynFlags -> MVar Status -> IO [HValue] -> IO Status sandboxIO dflags statusMVar thing = - block $ do -- fork starts blocked - id <- forkIO $ do res <- Exception.try (unblock $ rethrow dflags thing) + mask $ \restore -> do -- fork starts blocked + id <- forkIO $ do res <- Exception.try (restore $ rethrow dflags thing) putMVar statusMVar (Complete res) -- empty: can't block withInterruptsSentTo id $ takeMVar statusMVar @@ -380,9 +385,9 @@ rethrow dflags io = Exception.catch io $ \se -> do not (dopt Opt_BreakOnException dflags) then poke exceptionFlag 1 else case fromException se of - -- If it is an "Interrupted" exception, we allow + -- If it is a "UserInterrupt" exception, we allow -- a possible break by way of -fbreak-on-exception - Just Interrupted -> return () + Just UserInterrupt -> return () -- In any other case, we don't want to break _ -> poke exceptionFlag 0 @@ -586,7 +591,7 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do -- has been accidentally evaluated, or something else has gone wrong. -- So that we don't fall over in a heap when this happens, just don't -- bind any free variables instead, and we emit a warning. - mb_hValues <- mapM (getIdValFromApStack apStack) offsets + mb_hValues <- mapM (getIdValFromApStack apStack) (map fromIntegral offsets) let filtered_ids = [ id | (id, Just _hv) <- zip ids mb_hValues ] when (any isNothing mb_hValues) $ debugTraceMsg (hsc_dflags hsc_env) 1 $ @@ -609,18 +614,22 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do -- - tidy the type variables -- - globalise the Id (Ids are supposed to be Global, apparently). -- - let all_ids | isPointer result_id = result_id : new_ids - | otherwise = new_ids + let result_ok = isPointer result_id + && not (isUnboxedTupleType (idType result_id)) + + all_ids | result_ok = result_id : new_ids + | otherwise = new_ids (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys new_tyvars = unionVarSets tyvarss - let final_ids = zipWith setIdType all_ids tidy_tys + final_ids = zipWith setIdType all_ids tidy_tys ictxt0 = hsc_IC hsc_env ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars + Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ] - Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)] + when result_ok $ Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)] hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 } - return (hsc_env1, result_name:names, span) + return (hsc_env1, if result_ok then result_name:names else names, span) where mkNewId :: OccName -> Id -> IO Id mkNewId occ id = do @@ -785,43 +794,48 @@ fromListBL bound l = BL (length l) bound l [] -- we've built up in the InteractiveContext simply move to the new -- module. They always shadow anything in scope in the current context. setContext :: GhcMonad m => - [Module] -- ^ entire top level scope of these modules - -> [Module] -- ^ exports only of these modules - -> m () -setContext toplev_mods export_mods = do - hsc_env <- getSession - let old_ic = hsc_IC hsc_env - hpt = hsc_HPT hsc_env - -- - export_env <- liftIO $ mkExportEnv hsc_env export_mods - toplev_envs <- liftIO $ mapM (mkTopLevEnv hpt) toplev_mods - let all_env = foldr plusGlobalRdrEnv export_env toplev_envs - modifySession $ \_ -> - hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods, - ic_exports = export_mods, - ic_rn_gbl_env = all_env }} + [Module] -- ^ entire top level scope of these modules + -> [(Module, Maybe (ImportDecl RdrName))] -- ^ exports of these modules + -> m () +setContext toplev_mods other_mods = do + hsc_env <- getSession + let old_ic = hsc_IC hsc_env + hpt = hsc_HPT hsc_env + (decls,mods) = partition (isJust . snd) other_mods -- time for tracing + export_mods = map fst mods + imprt_decls = map noLoc (catMaybes (map snd decls)) + -- + export_env <- liftIO $ mkExportEnv hsc_env export_mods + import_env <- + if null imprt_decls then return emptyGlobalRdrEnv else do + let imports = rnImports imprt_decls + this_mod = if null toplev_mods then pRELUDE else head toplev_mods + (_, env, _,_) <- + ioMsgMaybe $ liftIO $ initTc hsc_env HsSrcFile False this_mod imports + return env + toplev_envs <- liftIO $ mapM (mkTopLevEnv hpt) toplev_mods + let all_env = foldr plusGlobalRdrEnv (plusGlobalRdrEnv export_env import_env) toplev_envs + modifySession $ \_ -> + hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods, + ic_exports = other_mods, + ic_rn_gbl_env = all_env }} -- Make a GlobalRdrEnv based on the exports of the modules only. mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv -mkExportEnv hsc_env mods = do - stuff <- mapM (getModuleExports hsc_env) mods - let - (_msgs, mb_name_sets) = unzip stuff - gres = [ nameSetToGlobalRdrEnv (availsToNameSet avails) (moduleName mod) - | (Just avails, mod) <- zip mb_name_sets mods ] - -- - return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres - -nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv -nameSetToGlobalRdrEnv names mod = - mkGlobalRdrEnv [ GRE { gre_name = name, gre_par = NoParent, gre_prov = vanillaProv mod } - | name <- nameSetToList names ] - -vanillaProv :: ModuleName -> Provenance --- We're building a GlobalRdrEnv as if the user imported --- all the specified modules into the global interactive module -vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}] +mkExportEnv hsc_env mods + = do { stuff <- mapM (getModuleExports hsc_env) mods + ; let (_msgs, mb_name_sets) = unzip stuff + envs = [ availsToGlobalRdrEnv (moduleName mod) avails + | (Just avails, mod) <- zip mb_name_sets mods ] + ; return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv envs } + +availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv +availsToGlobalRdrEnv mod_name avails + = mkGlobalRdrEnv (gresFromAvails imp_prov avails) where + -- We're building a GlobalRdrEnv as if the user imported + -- all the specified modules into the global interactive module + imp_prov = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}] decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name, is_qual = False, is_dloc = srcLocSpan interactiveSrcLoc } @@ -841,7 +855,7 @@ mkTopLevEnv hpt modl -- | Get the interactive evaluation context, consisting of a pair of the -- set of modules from which we take the full top-level scope, and the set -- of modules from which we take just the exports respectively. -getContext :: GhcMonad m => m ([Module],[Module]) +getContext :: GhcMonad m => m ([Module],[(Module, Maybe (ImportDecl RdrName))]) getContext = withSession $ \HscEnv{ hsc_IC=ic } -> return (ic_toplev_scope ic, ic_exports ic) @@ -918,14 +932,6 @@ parseName str = withSession $ \hsc_env -> do (L _ rdr_name) <- hscParseIdentifier (hsc_dflags hsc_env) str ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name --- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any --- entity known to GHC, including 'Name's defined using 'runStmt'. -lookupName :: GhcMonad m => Name -> m (Maybe TyThing) -lookupName name = withSession $ \hsc_env -> do - mb_tything <- ioMsg $ tcRnLookupName hsc_env name - return mb_tything - -- XXX: calls panic in some circumstances; is that ok? - -- ----------------------------------------------------------------------------- -- Getting the type of an expression @@ -965,7 +971,7 @@ dynCompileExpr expr = do setContext full $ (mkModule (stringToPackageId "base") (mkModuleName "Data.Dynamic") - ):exports + ,Nothing):exports let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")" Just (ids, hvals) <- withSession (flip hscStmt stmt) setContext full exports