X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcompMan%2FCompManager.lhs;h=54c43443acf0d5674cef69a51a1e993197dc78fa;hb=f01a539932e6386320bc0d4d049009de89507b4c;hp=6c1439bf34ab5a75f826152b02429a4985d4c493;hpb=c95b86624e5048b972e8b2a975ee7d09366df3bb;p=ghc-hetmet.git diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index 6c1439b..54c4344 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -4,6 +4,7 @@ \section[CompManager]{The Compilation Manager} \begin{code} +{-# OPTIONS -fvia-C #-} module CompManager ( cmInit, -- :: GhciMode -> IO CmState @@ -16,10 +17,13 @@ module CompManager ( cmGetContext, -- :: CmState -> IO String #ifdef GHCI - cmRunStmt, -- :: CmState -> DynFlags -> String -> IO (CmState, [Name]) + cmInfoThing, -- :: CmState -> DynFlags -> String -> IO (Maybe TyThing) - cmTypeOfExpr, -- :: CmState -> DynFlags -> String - -- -> IO (CmState, Maybe String) + CmRunResult(..), + cmRunStmt, -- :: CmState -> DynFlags -> String -> IO (CmState, CmRunResult) + + cmTypeOfExpr, -- :: CmState -> DynFlags -> String + -- -> IO (CmState, Maybe String) cmTypeOfName, -- :: CmState -> Name -> IO (Maybe String) @@ -34,38 +38,49 @@ where import CmLink import CmTypes -import CmStaticInfo ( GhciMode(..) ) import DriverPipeline import DriverFlags ( getDynFlags ) +import DriverState ( v_Output_file ) import DriverPhases import DriverUtil import Finder +#ifdef GHCI +import HscMain ( initPersistentCompilerState, hscThing ) +#else import HscMain ( initPersistentCompilerState ) +#endif import HscTypes -import RnEnv ( unQualInScope ) -import Id ( idType, idName ) -import Name ( Name, NamedThing(..), nameRdrName ) -import NameEnv +import Name ( Name, NamedThing(..), nameRdrName, nameModule, + isHomePackageName ) import RdrName ( lookupRdrEnv, emptyRdrEnv ) import Module import GetImports -import Type ( tidyType ) -import VarEnv ( emptyTidyEnv ) import UniqFM import Unique ( Uniquable ) -import Digraph ( SCC(..), stronglyConnComp, flattenSCC ) +import Digraph ( SCC(..), stronglyConnComp, flattenSCC, flattenSCCs ) import ErrUtils ( showPass ) +import SysTools ( cleanTempFilesExcept ) import Util -import TmpFiles import Outputable import Panic import CmdLineOpts ( DynFlags(..) ) + import IOExts #ifdef GHCI +import Id ( idType, idName ) +import NameEnv +import Type ( tidyType ) +import VarEnv ( emptyTidyEnv ) +import RnEnv ( unQualInScope ) +import BasicTypes ( Fixity, defaultFixity ) import Interpreter ( HValue ) import HscMain ( hscStmt ) import PrelGHC ( unsafeCoerce# ) + +import Foreign +import CForeign +import Exception ( Exception, try ) #endif -- lang @@ -142,7 +157,7 @@ cmInit mode = do cmSetContext :: CmState -> String -> IO CmState cmSetContext cmstate str = do let mn = mkModuleName str - modules_loaded = [ (name_of_summary s, ms_mod s) | s <- mg cmstate ] + modules_loaded = [ (name_of_summary s, ms_mod s) | s <- mg cmstate ] m <- case lookup mn modules_loaded of Just m -> return m @@ -168,13 +183,46 @@ moduleNameToModule mn Just (m,_) -> return m ----------------------------------------------------------------------------- +-- cmInfoThing: convert a String to a TyThing + +-- A string may refer to more than one TyThing (eg. a constructor, +-- and type constructor), so we return a list of all the possible TyThings. + +#ifdef GHCI +cmInfoThing :: CmState -> DynFlags -> String + -> IO (CmState, PrintUnqualified, [(TyThing,Fixity)]) +cmInfoThing cmstate dflags id + = do (new_pcs, things) <- hscThing dflags hst hit pcs icontext id + let pairs = map (\x -> (x, getFixity new_pcs (getName x))) things + return (cmstate{ pcs=new_pcs }, unqual, pairs) + where + CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls, ic=icontext } = cmstate + unqual = getUnqual pcs hit icontext + + getFixity :: PersistentCompilerState -> Name -> Fixity + getFixity pcs name + | Just iface <- lookupModuleEnv iface_table (nameModule name), + Just fixity <- lookupNameEnv (mi_fixities iface) name + = fixity + | otherwise + = defaultFixity + where iface_table | isHomePackageName name = hit + | otherwise = pcs_PIT pcs +#endif + +----------------------------------------------------------------------------- -- cmRunStmt: Run a statement/expr. #ifdef GHCI -cmRunStmt :: CmState -> DynFlags -> String - -> IO (CmState, -- new state - [Name]) -- names bound by this evaluation -cmRunStmt cmstate dflags expr +data CmRunResult + = CmRunOk [Name] -- names bound by this evaluation + | CmRunFailed + | CmRunDeadlocked -- statement deadlocked + | CmRunException Exception -- statement raised an exception + +cmRunStmt :: CmState -> DynFlags -> String -> IO (CmState, CmRunResult) +cmRunStmt cmstate@CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls, ic=icontext } + dflags expr = do let InteractiveContext { ic_rn_env = rn_env, @@ -185,7 +233,7 @@ cmRunStmt cmstate dflags expr <- hscStmt dflags hst hit pcs icontext expr False{-stmt-} case maybe_stuff of - Nothing -> return (cmstate{ pcs=new_pcs }, []) + Nothing -> return (cmstate{ pcs=new_pcs }, CmRunFailed) Just (ids, _, bcos) -> do -- update the interactive context @@ -212,17 +260,56 @@ cmRunStmt cmstate dflags expr -- run it! let thing_to_run = unsafeCoerce# hval :: IO [HValue] - hvals <- thing_to_run - - -- Get the newly bound things, and bind them. Don't forget - -- to delete any shadowed bindings from the closure_env, lest - -- we end up with a space leak. - pls <- delListFromClosureEnv pls shadowed - new_pls <- addListToClosureEnv pls (zip names hvals) - - return (cmstate{ pcs=new_pcs, pls=new_pls, ic=new_ic }, names) - where - CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls, ic=icontext } = cmstate + either_hvals <- sandboxIO thing_to_run + case either_hvals of + Left err + | err == dEADLOCKED + -> return ( cmstate{ pcs=new_pcs, ic=new_ic }, + CmRunDeadlocked ) + | otherwise + -> do hPutStrLn stderr ("unknown failure, code " ++ show err) + return ( cmstate{ pcs=new_pcs, ic=new_ic }, CmRunFailed ) + + Right maybe_hvals -> + case maybe_hvals of + Left e -> + return ( cmstate{ pcs=new_pcs, ic=new_ic }, + CmRunException e ) + Right hvals -> do + -- Get the newly bound things, and bind them. + -- Don't forget to delete any shadowed bindings from the + -- closure_env, lest we end up with a space leak. + pls <- delListFromClosureEnv pls shadowed + new_pls <- addListToClosureEnv pls (zip names hvals) + + return (cmstate{ pcs=new_pcs, pls=new_pls, ic=new_ic }, + CmRunOk names) + +-- We run the statement in a "sandbox", which amounts to calling into +-- the RTS to request a new main thread. The main benefit is that we +-- get to detect a deadlock this way, but also there's no danger that +-- exceptions raised by the expression can affect the interpreter. + +sandboxIO :: IO a -> IO (Either Int (Either Exception a)) +sandboxIO thing = do + st_thing <- newStablePtr (Exception.try thing) + alloca $ \ p_st_result -> do + stat <- rts_evalStableIO st_thing p_st_result + freeStablePtr st_thing + if stat == 1 + then do st_result <- peek p_st_result + result <- deRefStablePtr st_result + freeStablePtr st_result + return (Right result) + else do + return (Left (fromIntegral stat)) + +-- ToDo: slurp this in from ghc/includes/RtsAPI.h somehow +dEADLOCKED = 4 :: Int + +foreign import "rts_evalStableIO" {- safe -} + rts_evalStableIO :: StablePtr (IO a) -> Ptr (StablePtr a) -> IO CInt + -- more informative than the C type! #endif ----------------------------------------------------------------------------- @@ -238,17 +325,21 @@ cmTypeOfExpr cmstate dflags expr case maybe_stuff of Nothing -> return (new_cmstate, Nothing) - Just (_, ty, _) -> - let pit = pcs_PIT pcs - modname = moduleName (ic_module ic) - tidy_ty = tidyType emptyTidyEnv ty - str = case lookupIfaceByModName hit pit modname of - Nothing -> showSDoc (ppr tidy_ty) - Just iface -> showSDocForUser unqual (ppr tidy_ty) - where unqual = unQualInScope (mi_globals iface) - in return (new_cmstate, Just str) + Just (_, ty, _) -> return (new_cmstate, Just str) + where + str = showSDocForUser unqual (ppr tidy_ty) + unqual = getUnqual pcs hit ic + tidy_ty = tidyType emptyTidyEnv ty where CmState{ hst=hst, hit=hit, pcs=pcs, ic=ic } = cmstate + +getUnqual pcs hit ic + = case lookupIfaceByModName hit pit modname of + Nothing -> alwaysQualify + Just iface -> unQualInScope (mi_globals iface) + where + pit = pcs_PIT pcs + modname = moduleName (ic_module ic) #endif ----------------------------------------------------------------------------- @@ -259,15 +350,11 @@ cmTypeOfName :: CmState -> Name -> IO (Maybe String) cmTypeOfName CmState{ hit=hit, pcs=pcs, ic=ic } name = case lookupNameEnv (ic_type_env ic) name of Nothing -> return Nothing - Just (AnId id) -> - let pit = pcs_PIT pcs - modname = moduleName (ic_module ic) - ty = tidyType emptyTidyEnv (idType id) - str = case lookupIfaceByModName hit pit modname of - Nothing -> showSDoc (ppr ty) - Just iface -> showSDocForUser unqual (ppr ty) - where unqual = unQualInScope (mi_globals iface) - in return (Just str) + Just (AnId id) -> return (Just str) + where + unqual = getUnqual pcs hit ic + ty = tidyType emptyTidyEnv (idType id) + str = showSDocForUser unqual (ppr ty) _ -> panic "cmTypeOfName" #endif @@ -308,21 +395,6 @@ cmCompileExpr cmstate dflags expr #endif ----------------------------------------------------------------------------- --- cmInfo: return "info" about an expression. The info might be: --- --- * its type, for an expression, --- * the class definition, for a class --- * the datatype definition, for a tycon (or synonym) --- * the export list, for a module --- --- Can be used to find the type of the last expression compiled, by looking --- for "it". - -cmInfo :: CmState -> String -> IO (Maybe String) -cmInfo cmstate str - = do error "cmInfo not implemented yet" - ------------------------------------------------------------------------------ -- Unload the compilation manager's state: everything it knows about the -- current collection of modules in the Home package. @@ -344,12 +416,12 @@ cmUnload state@CmState{ gmode=mode, pls=pls, pcs=pcs } dflags -- the system state at the same time. cmLoadModule :: CmState - -> FilePath + -> [FilePath] -> IO (CmState, -- new state Bool, -- was successful [String]) -- list of modules loaded -cmLoadModule cmstate1 rootname +cmLoadModule cmstate1 rootnames = do -- version 1's are the original, before downsweep let pls1 = pls cmstate1 let pcs1 = pcs cmstate1 @@ -359,7 +431,6 @@ cmLoadModule cmstate1 rootname -- the previous pass, if any. let ui1 = ui cmstate1 let mg1 = mg cmstate1 - let ic1 = ic cmstate1 let ghci_mode = gmode cmstate1 -- this never changes @@ -369,9 +440,11 @@ cmLoadModule cmstate1 rootname showPass dflags "Chasing dependencies" when (verb >= 1 && ghci_mode == Batch) $ - hPutStrLn stderr (progName ++ ": chasing modules from: " ++ rootname) + hPutStrLn stderr (showSDoc (hcat [ + text progName, text ": chasing modules from: ", + hcat (punctuate comma (map text rootnames))])) - (mg2unsorted, a_root_is_Main) <- downsweep [rootname] mg1 + (mg2unsorted, a_root_is_Main) <- downsweep rootnames mg1 let mg2unsorted_names = map name_of_summary mg2unsorted -- reachable_from follows source as well as normal imports @@ -392,7 +465,7 @@ cmLoadModule cmstate1 rootname mg2_with_srcimps -- when (verb >= 2) $ -- putStrLn (showSDoc (text "Valid linkables:" - -- <+> ppr valid_linkables)) + -- <+> ppr valid_linkables)) -- Figure out a stable set of modules which can be retained -- the top level envs, to avoid upsweeping them. Goes to a @@ -420,7 +493,7 @@ cmLoadModule cmstate1 rootname -- unload any modules which aren't going to be re-linked this -- time around. - pls2 <- unload ghci_mode dflags stable_linkables pls1 + pls2 <- CmLink.unload ghci_mode dflags stable_linkables pls1 -- We could at this point detect cycles which aren't broken by -- a source-import, and complain immediately, but it seems better @@ -444,9 +517,13 @@ cmLoadModule cmstate1 rootname let threaded2 = CmThreaded pcs1 hst1 hit1 + -- clean up between compilations + let cleanup = cleanTempFilesExcept verb + (ppFilesFromSummaries (flattenSCCs upsweep_these)) + (upsweep_complete_success, threaded3, modsUpswept, newLis) <- upsweep_mods ghci_mode dflags valid_linkables reachable_from - threaded2 upsweep_these + threaded2 cleanup upsweep_these let ui3 = add_to_ui valid_linkables newLis let (CmThreaded pcs3 hst3 hit3) = threaded3 @@ -476,6 +553,13 @@ cmLoadModule cmstate1 rootname -- clean up after ourselves cleanTempFilesExcept verb (ppFilesFromSummaries modsDone) + -- issue a warning for the confusing case where the user said '-o foo' + -- but we're not going to do any linking. + ofile <- readIORef v_Output_file + when (ghci_mode == Batch && isJust ofile && not a_root_is_Main + && verb > 0) $ + hPutStrLn stderr "Warning: output was redirected with -o, but no output will be generated\nbecause there is no Main module." + -- link everything together linkresult <- link ghci_mode dflags a_root_is_Main ui3 pls2 @@ -513,33 +597,43 @@ cmLoadModule cmstate1 rootname -- Finish up after a cmLoad. --- + +-- If the link failed, unload everything and return. +cmLoadFinish ok (LinkFailed pls) hst hit ui mods ghci_mode pcs = do + dflags <- getDynFlags + new_pls <- CmLink.unload ghci_mode dflags [] pls + new_state <- cmInit ghci_mode + return (new_state{ pcs=pcs, pls=new_pls }, False, []) + -- Empty the interactive context and set the module context to the topmost -- newly loaded module, or the Prelude if none were loaded. -cmLoadFinish ok linkresult hst hit ui mods ghci_mode pcs - = do case linkresult of { - LinkErrs _ _ -> panic "cmLoadModule: link failed (2)"; - LinkOK pls -> do - - def_mod <- readIORef defaultCurrentModule +cmLoadFinish ok (LinkOK pls) hst hit ui mods ghci_mode pcs + = do def_mod <- readIORef defaultCurrentModule let current_mod = case mods of [] -> def_mod (x:_) -> ms_mod x new_ic = emptyInteractiveContext current_mod - new_cmstate = CmState{ hst=hst, hit=hit, - ui=ui, mg=mods, - gmode=ghci_mode, pcs=pcs, - pls=pls, + new_cmstate = CmState{ hst=hst, hit=hit, ui=ui, mg=mods, + gmode=ghci_mode, pcs=pcs, pls=pls, ic = new_ic } mods_loaded = map (moduleNameUserString.name_of_summary) mods return (new_cmstate, ok, mods_loaded) - } +-- used to fish out the preprocess output files for the purposes +-- of cleaning up. ppFilesFromSummaries summaries - = [ fn | Just fn <- map (ml_hspp_file . ms_location) summaries ] + = [ fn | Just fn <- map toPpFile summaries ] + where + toPpFile sum + | hspp /= ml_hs_file loc = hspp + | otherwise = Nothing + where + loc = ms_location sum + hspp = ml_hspp_file loc + ----------------------------------------------------------------------------- -- getValidLinkables @@ -575,7 +669,10 @@ getValidLinkablesSCC old_linkables all_home_mods new_linkables scc0 scc = flattenSCC scc0 scc_names = map name_of_summary scc home_module m = m `elem` all_home_mods && m `notElem` scc_names - scc_allhomeimps = nub (filter home_module (concatMap ms_allimps scc)) + scc_allhomeimps = nub (filter home_module (concatMap ms_imps scc)) + -- NOTE: ms_imps, not ms_allimps above. We don't want to + -- force a module's SOURCE imports to be already compiled for + -- its object linkable to be valid. has_object m = case findModuleLinkable_maybe new_linkables m of Nothing -> False @@ -636,12 +733,17 @@ getValidLinkable old_linkables objects_allowed new_linkables summary src_date = ms_hs_date summary valid_linkable - = filter (\l -> linkableTime l > src_date) linkable + = filter (\l -> linkableTime l >= src_date) linkable + -- why '>=' rather than '>' above? If the filesystem stores + -- times to the nearset second, we may occasionally find that + -- the object & source have the same modification time, + -- especially if the source was automatically generated + -- and compiled. Using >= is slightly unsafe, but it matches + -- make's behaviour. return (valid_linkable ++ new_linkables) - maybe_getFileLinkable :: ModuleName -> FilePath -> IO (Maybe Linkable) maybe_getFileLinkable mod_name obj_fn = do obj_exist <- doesFileExist obj_fn @@ -760,6 +862,7 @@ upsweep_mods :: GhciMode -> UnlinkedImage -- valid linkables -> (ModuleName -> [ModuleName]) -- to construct downward closures -> CmThreaded -- PCS & HST & HIT + -> IO () -- how to clean up unwanted tmp files -> [SCC ModSummary] -- mods to do (the worklist) -- ...... RETURNING ...... -> IO (Bool{-complete success?-}, @@ -767,17 +870,17 @@ upsweep_mods :: GhciMode [ModSummary], -- mods which succeeded [Linkable]) -- new linkables -upsweep_mods ghci_mode dflags oldUI reachable_from threaded +upsweep_mods ghci_mode dflags oldUI reachable_from threaded cleanup [] = return (True, threaded, [], []) -upsweep_mods ghci_mode dflags oldUI reachable_from threaded +upsweep_mods ghci_mode dflags oldUI reachable_from threaded cleanup ((CyclicSCC ms):_) = do hPutStrLn stderr ("Module imports form a cycle for modules:\n\t" ++ unwords (map (moduleNameUserString.name_of_summary) ms)) return (False, threaded, [], []) -upsweep_mods ghci_mode dflags oldUI reachable_from threaded +upsweep_mods ghci_mode dflags oldUI reachable_from threaded cleanup ((AcyclicSCC mod):mods) = do --case threaded of -- CmThreaded pcsz hstz hitz @@ -786,12 +889,16 @@ upsweep_mods ghci_mode dflags oldUI reachable_from threaded (threaded1, maybe_linkable) <- upsweep_mod ghci_mode dflags oldUI threaded mod (reachable_from (name_of_summary mod)) + + -- remove unwanted tmp files between compilations + cleanup + case maybe_linkable of Just linkable -> -- No errors; do the rest do (restOK, threaded2, modOKs, linkables) <- upsweep_mods ghci_mode dflags oldUI reachable_from - threaded1 mods + threaded1 cleanup mods return (restOK, threaded2, mod:modOKs, linkable:linkables) Nothing -- we got a compilation error; give up now -> return (False, threaded1, [], []) @@ -810,7 +917,6 @@ upsweep_mod :: GhciMode upsweep_mod ghci_mode dflags oldUI threaded1 summary1 reachable_inc_me = do let mod_name = name_of_summary summary1 - let verb = verbosity dflags let (CmThreaded pcs1 hst1 hit1) = threaded1 let old_iface = lookupUFM hit1 mod_name @@ -887,10 +993,9 @@ downwards_closure_of_module summaries root res = simple_transitive_closure (map toEdge summaries) [root] in - --trace (showSDoc (text "DC of mod" <+> ppr root - -- <+> text "=" <+> ppr res)) ( +-- trace (showSDoc (text "DC of mod" <+> ppr root +-- <+> text "=" <+> ppr res)) $ res - --) -- Calculate transitive closures from a set of roots given an adjacency list simple_transitive_closure :: Eq a => [(a,[a])] -> [a] -> [a] @@ -1015,10 +1120,10 @@ summariseFile file = do hspp_fn <- preprocess file (srcimps,imps,mod_name) <- getImportsFromFile hspp_fn - let (path, basename, ext) = splitFilename3 file + let (path, basename, _ext) = splitFilename3 file - Just (mod, location) - <- mkHomeModuleLocn mod_name (path ++ '/':basename) (Just file) + (mod, location) + <- mkHomeModuleLocn mod_name (path ++ '/':basename) file src_timestamp <- case ml_hs_file location of @@ -1038,14 +1143,7 @@ summarise mod location old_summary = do let hs_fn = unJust "summarise" (ml_hs_file location) case ml_hs_file location of { - Nothing -> do { - dflags <- getDynFlags; - when (verbosity dflags >= 1) $ - hPutStrLn stderr ("WARNING: module `" ++ - moduleUserString mod ++ "' has no source file."); - return Nothing; - }; - + Nothing -> noHsFileErr mod; Just src_fn -> do src_timestamp <- getModificationTime src_fn