X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FGHC.hs;h=047781ededaa01d347ffb352e5a492056301a002;hb=16dc208aaad7aadaea970e47b8055d7d7f8781e5;hp=a918d60bdb4504c07ba4e0d9a5a5e97f38a35ea3;hpb=78f4da288f8a189c739766a3107fa80073800ba7;p=ghc-hetmet.git diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index a918d60..047781e 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -84,7 +84,8 @@ module GHC ( resume, Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan, resumeHistory, resumeHistoryIx), - History(historyBreakInfo), getHistorySpan, + History(historyBreakInfo, historyEnclosingDecl), + GHC.getHistorySpan, getHistoryModule, getResumeContext, abandon, abandonAll, InteractiveEval.back, @@ -93,7 +94,7 @@ module GHC ( isModuleInterpreted, compileExpr, HValue, dynCompileExpr, lookupName, - obtainTerm, obtainTerm1, + GHC.obtainTerm, GHC.obtainTerm1, GHC.obtainTermB, reconstructType, modInfoModBreaks, ModBreaks(..), BreakIndex, BreakInfo(breakInfo_number, breakInfo_module), @@ -226,9 +227,7 @@ import Name hiding ( varName ) import OccName ( parenSymOcc ) import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr ) import SrcLoc -import Desugar import CoreSyn -import TcRnDriver ( tcRnModule ) import DriverPipeline import DriverPhases ( HscSource(..), Phase(..), isHaskellSrcFilename, startPhase ) import HeaderInfo ( getImports, getOptions ) @@ -538,10 +537,18 @@ load s@(Session ref) how_much -- graph is still retained in the Session. We can tell which modules -- were successfully loaded by inspecting the Session's HPT. mb_graph <- depanal s [] False - case mb_graph of - Just mod_graph -> load2 s how_much mod_graph + case mb_graph of + Just mod_graph -> catchingFailure $ load2 s how_much mod_graph Nothing -> return Failed - + where catchingFailure f = f `Exception.catch` \e -> do + hsc_env <- readIORef ref + -- trac #1565 / test ghci021: + -- let bindings may explode if we try to use them after + -- failing to reload + writeIORef ref $! hsc_env{ hsc_IC = emptyInteractiveContext } + throw e + +load2 :: Session -> LoadHowMuch -> [ModSummary] -> IO SuccessFlag load2 s@(Session ref) how_much mod_graph = do guessOutputFile s hsc_env <- readIORef ref @@ -627,9 +634,9 @@ load2 s@(Session ref) how_much mod_graph = do -- short of the specified module (unless the specified module -- is stable). partial_mg - | LoadDependenciesOf mod <- how_much + | LoadDependenciesOf _mod <- how_much = ASSERT( case last partial_mg0 of - AcyclicSCC ms -> ms_mod_name ms == mod; _ -> False ) + AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False ) List.init partial_mg0 | otherwise = partial_mg0 @@ -731,7 +738,8 @@ load2 s@(Session ref) how_much mod_graph = do -- Finish up after a load. -- If the link failed, unload everything and return. -loadFinish all_ok Failed ref hsc_env +loadFinish :: SuccessFlag -> SuccessFlag -> IORef HscEnv -> HscEnv -> IO SuccessFlag +loadFinish _all_ok Failed ref hsc_env = do unload hsc_env [] writeIORef ref $! discardProg hsc_env return Failed @@ -753,6 +761,7 @@ discardProg hsc_env -- used to fish out the preprocess output files for the purposes of -- cleaning up. The preprocessed file *might* be the same as the -- source file, but that doesn't do any harm. +ppFilesFromSummaries :: [ModSummary] -> [FilePath] ppFilesFromSummaries summaries = map ms_hspp_file summaries -- ----------------------------------------------------------------------------- @@ -795,7 +804,7 @@ type TypecheckedSource = LHsBinds Id -- If compileToCore is true, it also desugars the module and returns the -- resulting Core bindings as a component of the CheckedModule. checkModule :: Session -> ModuleName -> Bool -> IO (Maybe CheckedModule) -checkModule session@(Session ref) mod compileToCore = do +checkModule (Session ref) mod compileToCore = do -- parse & typecheck the module hsc_env <- readIORef ref let mg = hsc_mod_graph hsc_env @@ -839,8 +848,7 @@ checkModule session@(Session ref) mod compileToCore = do -- desugar the module, then returns the resulting list of Core bindings if -- successful. compileToCore :: Session -> FilePath -> IO (Maybe [CoreBind]) -compileToCore session@(Session ref) fn = do - hsc_env <- readIORef ref +compileToCore session fn = do -- First, set the target to the desired filename target <- guessTarget fn Nothing addTarget session target @@ -850,13 +858,13 @@ compileToCore session@(Session ref) fn = do case maybeModGraph of Nothing -> return Nothing Just modGraph -> do - case find ((== fn) . msHsFilePath) modGraph of - Just modSummary -> do - -- Now we have the module name; - -- parse, typecheck and desugar the module - let mod = ms_mod_name modSummary - maybeCheckedModule <- checkModule session mod True - case maybeCheckedModule of + let modSummary = expectJust "compileToCore" $ + find ((== fn) . msHsFilePath) modGraph + -- Now we have the module name; + -- parse, typecheck and desugar the module + let mod = ms_mod_name modSummary + maybeCheckedModule <- checkModule session mod True + case maybeCheckedModule of Nothing -> return Nothing Just checkedMod -> return $ coreBinds checkedMod -- --------------------------------------------------------------------------- @@ -869,8 +877,10 @@ unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables #else LinkInMemory -> panic "unload: no interpreter" + -- urgh. avoid warnings: + hsc_env stable_linkables #endif - other -> return () + _other -> return () -- ----------------------------------------------------------------------------- -- checkStability @@ -1026,7 +1036,7 @@ findPartiallyCompletedCycles modsDone theGraph = chew theGraph where chew [] = [] - chew ((AcyclicSCC v):rest) = chew rest -- acyclic? not interesting. + chew ((AcyclicSCC _):rest) = chew rest -- acyclic? not interesting. chew ((CyclicSCC vs):rest) = let names_in_this_cycle = nub (map ms_mod vs) mods_in_this_cycle @@ -1059,17 +1069,18 @@ upsweep upsweep hsc_env old_hpt stable_mods cleanup mods = upsweep' hsc_env old_hpt stable_mods cleanup mods 1 (length mods) + where -upsweep' hsc_env old_hpt stable_mods cleanup + upsweep' hsc_env _old_hpt _stable_mods _cleanup [] _ _ = return (Succeeded, hsc_env, []) -upsweep' hsc_env old_hpt stable_mods cleanup + upsweep' hsc_env _old_hpt _stable_mods _cleanup (CyclicSCC ms:_) _ _ = do fatalErrorMsg (hsc_dflags hsc_env) (cyclicModuleErr ms) return (Failed, hsc_env, []) -upsweep' hsc_env old_hpt stable_mods cleanup + upsweep' hsc_env old_hpt stable_mods cleanup (AcyclicSCC mod:mods) mod_index nmods = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ -- show (map (moduleUserString.moduleName.mi_module.hm_iface) @@ -1166,11 +1177,11 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods iface = hm_iface hm_info compile_it :: Maybe Linkable -> IO (Maybe HomeModInfo) - compile_it = upsweep_compile hsc_env old_hpt this_mod_name + compile_it = upsweep_compile hsc_env summary' mod_index nmods mb_old_iface compile_it_discard_iface - = upsweep_compile hsc_env old_hpt this_mod_name + = upsweep_compile hsc_env summary' mod_index nmods Nothing in @@ -1234,10 +1245,9 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods -- Run hsc to compile a module -upsweep_compile hsc_env old_hpt this_mod summary - mod_index nmods - mb_old_iface - mb_old_linkable +upsweep_compile :: HscEnv -> ModSummary -> Int -> Int + -> Maybe ModIface -> Maybe Linkable -> IO (Maybe HomeModInfo) +upsweep_compile hsc_env summary mod_index nmods mb_old_iface mb_old_linkable = do compresult <- compile hsc_env summary mb_old_linkable mb_old_iface mod_index nmods @@ -1370,11 +1380,11 @@ warnUnnecessarySourceImports dflags sccs = printBagOfWarnings dflags (listToBag (concat (map (check.flattenSCC) sccs))) where check ms = let mods_in_this_cycle = map ms_mod_name ms in - [ warn m i | m <- ms, i <- ms_srcimps m, + [ warn i | m <- ms, i <- ms_srcimps m, unLoc i `notElem` mods_in_this_cycle ] - warn :: ModSummary -> Located ModuleName -> WarnMsg - warn ms (L loc mod) = + warn :: Located ModuleName -> WarnMsg + warn (L loc mod) = mkPlainErrMsg loc (ptext SLIT("Warning: {-# SOURCE #-} unnecessary in import of ") <+> quotes (ppr mod)) @@ -1574,7 +1584,7 @@ findSummaryBySourceFile summaries file = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms], expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of [] -> Nothing - (x:xs) -> Just x + (x:_) -> Just x -- Summarise a module, and pick up source and timestamp. summariseModule @@ -1686,6 +1696,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc ms_obj_date = obj_timestamp })) +getObjTimestamp :: ModLocation -> Bool -> IO (Maybe ClockTime) getObjTimestamp location is_boot = if is_boot then return Nothing else modificationTimeIfExists (ml_obj_file location) @@ -1699,13 +1710,14 @@ preprocessFile dflags src_fn mb_phase Nothing buf <- hGetStringBuffer hspp_fn return (dflags', hspp_fn, buf) -preprocessFile dflags src_fn mb_phase (Just (buf, time)) +preprocessFile dflags src_fn mb_phase (Just (buf, _time)) = do -- case we bypass the preprocessing stage? let local_opts = getOptions buf src_fn -- - (dflags', errs) <- parseDynamicFlags dflags (map unLoc local_opts) + (dflags', _errs) <- parseDynamicFlags dflags (map unLoc local_opts) + -- XXX: shouldn't we be reporting the errors? let needs_preprocessing @@ -1731,14 +1743,17 @@ noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab noModError dflags loc wanted_mod err = throwDyn $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err +noHsFileErr :: SrcSpan -> String -> a noHsFileErr loc path = throwDyn $ mkPlainErrMsg loc $ text "Can't find" <+> text path +packageModErr :: ModuleName -> a packageModErr mod = throwDyn $ mkPlainErrMsg noSrcSpan $ text "module" <+> quotes (ppr mod) <+> text "is a package module" multiRootsErr :: [ModSummary] -> IO () +multiRootsErr [] = panic "multiRootsErr" multiRootsErr summs@(summ1:_) = throwDyn $ mkPlainErrMsg noSrcSpan $ text "module" <+> quotes (ppr mod) <+> @@ -1826,8 +1841,8 @@ getModuleInfo s mdl = withSession s $ \hsc_env -> do -- exist... hence the isHomeModule test here. (ToDo: reinstate) getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) -getPackageModuleInfo hsc_env mdl = do #ifdef GHCI +getPackageModuleInfo hsc_env mdl = do (_msgs, mb_avails) <- getModuleExports hsc_env mdl case mb_avails of Nothing -> return Nothing @@ -1847,10 +1862,12 @@ getPackageModuleInfo hsc_env mdl = do minf_modBreaks = emptyModBreaks })) #else +getPackageModuleInfo _hsc_env _mdl = do -- bogusly different for non-GHCI (ToDo) return Nothing #endif +getHomeModuleInfo :: HscEnv -> ModuleName -> IO (Maybe ModuleInfo) getHomeModuleInfo hsc_env mdl = case lookupUFM (hsc_HPT hsc_env) mdl of Nothing -> return Nothing @@ -1862,7 +1879,7 @@ getHomeModuleInfo hsc_env mdl = minf_rdr_env = mi_globals $! hm_iface hmi, minf_instances = md_insts details #ifdef GHCI - ,minf_modBreaks = md_modBreaks details + ,minf_modBreaks = getModBreaks hmi #endif })) @@ -1898,12 +1915,13 @@ modInfoLookupName s minf name = withSession s $ \hsc_env -> do (hsc_HPT hsc_env) (eps_PTE eps) name #ifdef GHCI +modInfoModBreaks :: ModuleInfo -> ModBreaks modInfoModBreaks = minf_modBreaks #endif isDictonaryId :: Id -> Bool isDictonaryId id - = case tcSplitSigmaTy (idType id) of { (tvs, theta, tau) -> isDictTy tau } + = case tcSplitSigmaTy (idType id) of { (_tvs, _theta, tau) -> isDictTy tau } -- | Looks up a global name: that is, any top-level name in any -- visible module. Unlike 'lookupName', lookupGlobalName does not use @@ -1955,9 +1973,6 @@ getTokenStream :: Session -> Module -> IO [Located Token] -- using the algorithm that is used for an @import@ declaration. findModule :: Session -> ModuleName -> Maybe PackageId -> IO Module findModule s mod_name maybe_pkg = withSession s $ \hsc_env -> - findModule' hsc_env mod_name maybe_pkg - -findModule' hsc_env mod_name maybe_pkg = let dflags = hsc_dflags hsc_env hpt = hsc_HPT hsc_env @@ -1974,3 +1989,22 @@ findModule' hsc_env mod_name maybe_pkg = text "is not loaded")) err -> let msg = cannotFindModule dflags mod_name err in throwDyn (CmdLineError (showSDoc msg)) + +#ifdef GHCI +getHistorySpan :: Session -> History -> IO SrcSpan +getHistorySpan sess h = withSession sess $ \hsc_env -> + return$ InteractiveEval.getHistorySpan hsc_env h + +obtainTerm :: Session -> Bool -> Id -> IO Term +obtainTerm sess force id = withSession sess $ \hsc_env -> + InteractiveEval.obtainTerm hsc_env force id + +obtainTerm1 :: Session -> Bool -> Maybe Type -> a -> IO Term +obtainTerm1 sess force mb_ty a = withSession sess $ \hsc_env -> + InteractiveEval.obtainTerm1 hsc_env force mb_ty a + +obtainTermB :: Session -> Int -> Bool -> Id -> IO Term +obtainTermB sess bound force id = withSession sess $ \hsc_env -> + InteractiveEval.obtainTermB hsc_env bound force id + +#endif