X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FGHC.hs;h=bf1bd77f36e417741b542f9db9a76ccac3b5c1bc;hb=8102af4eac807ae4956a79b27f03fd890f8294c6;hp=846bec16bdb161ad3c472a8609e5e1a82434c55e;hpb=3b1438a9757639d7f37f10e1237e2369ca0ebe4a;p=ghc-hetmet.git diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 846bec1..bf1bd77 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -41,7 +41,7 @@ module GHC ( workingDirectoryChanged, checkModule, CheckedModule(..), TypecheckedSource, ParsedSource, RenamedSource, - compileToCore, + compileToCore, compileToCoreModule, -- * Parsing Haddock comments parseHaddockComment, @@ -154,8 +154,8 @@ module GHC ( instanceDFunId, pprInstance, pprInstanceHdr, -- ** Types and Kinds - Type, dropForAlls, splitForAllTys, funResultTy, - pprParendType, pprTypeApp, + Type, splitForAllTys, funResultTy, + pprParendType, pprTypeApp, Kind, PredType, ThetaType, pprThetaArrow, @@ -244,7 +244,6 @@ import Module import UniqFM import UniqSet import Unique -import PackageConfig import FiniteMap import Panic import Digraph @@ -772,7 +771,7 @@ data CheckedModule = renamedSource :: Maybe RenamedSource, typecheckedSource :: Maybe TypecheckedSource, checkedModuleInfo :: Maybe ModuleInfo, - coreBinds :: Maybe [CoreBind] + coreModule :: Maybe CoreModule } -- ToDo: improvements that could be made here: -- if the module succeeded renaming but not typechecking, @@ -822,7 +821,7 @@ checkModule (Session ref) mod compileToCore = do renamedSource = renamed, typecheckedSource = Nothing, checkedModuleInfo = Nothing, - coreBinds = Nothing })) + coreModule = Nothing })) Just (HscChecked parsed renamed (Just (tc_binds, rdr_env, details)) maybeCoreBinds) -> do @@ -841,14 +840,15 @@ checkModule (Session ref) mod compileToCore = do renamedSource = renamed, typecheckedSource = Just tc_binds, checkedModuleInfo = Just minf, - coreBinds = maybeCoreBinds})) + coreModule = maybeCoreBinds})) -- | This is the way to get access to the Core bindings corresponding -- to a module. 'compileToCore' invokes 'checkModule' to parse, typecheck, and --- desugar the module, then returns the resulting list of Core bindings if --- successful. -compileToCore :: Session -> FilePath -> IO (Maybe [CoreBind]) -compileToCore session fn = do +-- desugar the module, then returns the resulting Core module (consisting of +-- the module name, type declarations, and function declarations) if +-- successful. +compileToCoreModule :: Session -> FilePath -> IO (Maybe CoreModule) +compileToCoreModule session fn = do -- First, set the target to the desired filename target <- guessTarget fn Nothing addTarget session target @@ -858,16 +858,26 @@ compileToCore session fn = do case maybeModGraph of Nothing -> return Nothing Just modGraph -> do - 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 + 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 Nothing -> return Nothing - Just checkedMod -> return $ coreBinds checkedMod - -- --------------------------------------------------------------------------- + Just checkedMod -> return $ coreModule checkedMod + Nothing -> panic "compileToCoreModule: target FilePath not found in\ + module dependency graph" + +-- | Provided for backwards-compatibility: compileToCore returns just the Core +-- bindings, but for most purposes, you probably want to call +-- compileToCoreModule. +compileToCore :: Session -> FilePath -> IO (Maybe [CoreBind]) +compileToCore session fn = do + maybeCoreModule <- compileToCoreModule session fn + return $ fmap cm_binds maybeCoreModule +-- --------------------------------------------------------------------------- -- Unloading unload :: HscEnv -> [Linkable] -> IO () @@ -1181,12 +1191,10 @@ 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 - summary' mod_index nmods mb_old_iface + compile_it = compile hsc_env summary' mod_index nmods mb_old_iface compile_it_discard_iface - = upsweep_compile hsc_env - summary' mod_index nmods Nothing + = compile hsc_env summary' mod_index nmods Nothing in case target of @@ -1248,27 +1256,6 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods compile_it Nothing --- Run hsc to compile a module -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 - - case compresult of - -- Compilation failed. Compile may still have updated the PCS, tho. - CompErrs -> return Nothing - - -- Compilation "succeeded", and may or may not have returned a new - -- linkable (depending on whether compilation was actually performed - -- or not). - CompOK new_details new_iface new_linkable - -> do let new_info = HomeModInfo { hm_iface = new_iface, - hm_details = new_details, - hm_linkable = new_linkable } - return (Just new_info) - -- Filter modules in the HPT retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable @@ -1635,7 +1622,7 @@ summariseFile hsc_env old_summaries file mb_phase maybe_buf (dflags', hspp_fn, buf) <- preprocessFile dflags file mb_phase maybe_buf - (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn + (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file -- Make a ModLocation for this file location <- mkHomeModLocation dflags mod_name file @@ -1755,7 +1742,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc -- Preprocess the source file and get its imports -- The dflags' contains the OPTIONS pragmas (dflags', hspp_fn, buf) <- preprocessFile dflags src_fn Nothing maybe_buf - (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn + (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn when (mod_name /= wanted_mod) $ throwDyn $ mkPlainErrMsg mod_loc $