From 78f4da288f8a189c739766a3107fa80073800ba7 Mon Sep 17 00:00:00 2001 From: Tim Chevalier Date: Fri, 29 Jun 2007 01:48:31 +0000 Subject: [PATCH] Further compileToCore improvements Per suggestions from Simon M: * Changed GHC.checkModule so that it doesn't call depanal. * Changed GHC.checkModule to optionally return Core bindings as a component of the CheckedModule that it returns (and resulting changes to HscMain.hscFileCheck). * As a result, simplified GHC.compileToCore and changed it to load the given file so that the caller doesn't have to. --- compiler/ghci/InteractiveUI.hs | 2 +- compiler/main/GHC.hs | 83 +++++++++++++++++++--------------------- compiler/main/HscMain.lhs | 20 +++++++--- 3 files changed, 54 insertions(+), 51 deletions(-) diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 4c81bf4..fe32e83 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -865,7 +865,7 @@ checkModule :: String -> GHCi () checkModule m = do let modl = GHC.mkModuleName m session <- getSession - result <- io (GHC.checkModule session modl) + result <- io (GHC.checkModule session modl False) case result of Nothing -> io $ putStrLn "Nothing" Just r -> io $ putStrLn (showSDoc ( diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 683bc57..a918d60 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -762,7 +762,8 @@ data CheckedModule = CheckedModule { parsedSource :: ParsedSource, renamedSource :: Maybe RenamedSource, typecheckedSource :: Maybe TypecheckedSource, - checkedModuleInfo :: Maybe ModuleInfo + checkedModuleInfo :: Maybe ModuleInfo, + coreBinds :: Maybe [CoreBind] } -- ToDo: improvements that could be made here: -- if the module succeeded renaming but not typechecking, @@ -789,32 +790,33 @@ type TypecheckedSource = LHsBinds Id -- | This is the way to get access to parsed and typechecked source code --- for a module. 'checkModule' loads all the dependencies of the specified --- module in the Session, and then attempts to typecheck the module. If +-- for a module. 'checkModule' attempts to typecheck the module. If -- successful, it returns the abstract syntax for the module. -checkModule :: Session -> ModuleName -> IO (Maybe CheckedModule) -checkModule session@(Session ref) mod = do - -- load up the dependencies first - r <- load session (LoadDependenciesOf mod) - if (failed r) then return Nothing else do - - -- now parse & typecheck the module +-- 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 + -- parse & typecheck the module hsc_env <- readIORef ref let mg = hsc_mod_graph hsc_env case [ ms | ms <- mg, ms_mod_name ms == mod ] of [] -> return Nothing (ms:_) -> do - mbChecked <- hscFileCheck hsc_env{hsc_dflags=ms_hspp_opts ms} ms + mbChecked <- hscFileCheck + hsc_env{hsc_dflags=ms_hspp_opts ms} + ms compileToCore case mbChecked of Nothing -> return Nothing - Just (HscChecked parsed renamed Nothing) -> + Just (HscChecked parsed renamed Nothing _) -> return (Just (CheckedModule { parsedSource = parsed, renamedSource = renamed, typecheckedSource = Nothing, - checkedModuleInfo = Nothing })) + checkedModuleInfo = Nothing, + coreBinds = Nothing })) Just (HscChecked parsed renamed - (Just (tc_binds, rdr_env, details))) -> do + (Just (tc_binds, rdr_env, details)) + maybeCoreBinds) -> do let minf = ModuleInfo { minf_type_env = md_types details, minf_exports = availsToNameSet $ @@ -829,41 +831,34 @@ checkModule session@(Session ref) mod = do parsedSource = parsed, renamedSource = renamed, typecheckedSource = Just tc_binds, - checkedModuleInfo = Just minf })) + checkedModuleInfo = Just minf, + coreBinds = maybeCoreBinds})) -- | This is the way to get access to the Core bindings corresponding --- to a module. 'compileToCore' first invokes 'checkModule' to parse and --- typecheck the module, then desugars it and returns the resulting list --- of Core bindings if successful. It is assumed that the given filename --- has already been loaded. +-- 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@(Session ref) fn = do hsc_env <- readIORef ref - -- First, determine the module name. - modSummary <- summariseFile hsc_env [] fn Nothing Nothing - let mod = moduleName $ ms_mod modSummary - -- Next, parse and typecheck the module - maybeCheckedModule <- checkModule session mod - case maybeCheckedModule of - Nothing -> return Nothing - Just checkedMod -> do - let parsedMod = parsedSource checkedMod - -- Note: this typechecks the module twice (because checkModule - -- also calls tcRnModule), but arranging for checkModule to - -- return the type env would require changing a lot of data - -- structures, so I'm leaving it like that for now. - (_, maybe_tc_result) <- tcRnModule hsc_env HsSrcFile False parsedMod - -- Get the type environment from the typechecking result - case maybe_tc_result of - -- TODO: this ignores the type error messages and just returns Nothing - Nothing -> return Nothing - Just tcgEnv -> do - let dflags = hsc_dflags hsc_env - -- Finally, compile to Core and return the resulting bindings - maybeModGuts <- deSugar hsc_env (ms_location modSummary) tcgEnv - case maybeModGuts of - Nothing -> return Nothing - Just mg -> return $ Just $ mg_binds mg + -- First, set the target to the desired filename + target <- guessTarget fn Nothing + addTarget session target + load session LoadAllTargets + -- Then find dependencies + maybeModGraph <- depanal session [] True + 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 + Nothing -> return Nothing + Just checkedMod -> return $ coreBinds checkedMod -- --------------------------------------------------------------------------- -- Unloading diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 282ec0f..c86bd48 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -51,6 +51,7 @@ import Module ( emptyModuleEnv, ModLocation(..) ) import RdrName ( GlobalRdrEnv, RdrName, emptyGlobalRdrEnv ) import HsSyn ( HsModule, LHsBinds, HsGroup, LIE, LImportDecl, HsDoc, HaddockModInfo ) +import CoreSyn import SrcLoc ( Located(..) ) import StringBuffer ( hGetStringBuffer, stringToStringBuffer ) import Parser @@ -183,7 +184,8 @@ data HscChecked Maybe (HsDoc Name), HaddockModInfo Name)) -- typechecked (Maybe (LHsBinds Id, GlobalRdrEnv, ModDetails)) - + -- desugared + (Maybe [CoreBind]) -- Status of a compilation to hard-code or nothing. data HscStatus @@ -646,8 +648,8 @@ hscInteractive (iface, details, cgguts) ------------------------------ -hscFileCheck :: HscEnv -> ModSummary -> IO (Maybe HscChecked) -hscFileCheck hsc_env mod_summary = do { +hscFileCheck :: HscEnv -> ModSummary -> Bool -> IO (Maybe HscChecked) +hscFileCheck hsc_env mod_summary compileToCore = do { ------------------- -- PARSE ------------------- @@ -673,7 +675,7 @@ hscFileCheck hsc_env mod_summary = do { ; printErrorsAndWarnings dflags tc_msgs ; case maybe_tc_result of { - Nothing -> return (Just (HscChecked rdr_module Nothing Nothing)); + Nothing -> return (Just (HscChecked rdr_module Nothing Nothing Nothing)); Just tc_result -> do let type_env = tcg_type_env tc_result md = ModDetails { @@ -696,11 +698,17 @@ hscFileCheck hsc_env mod_summary = do { let doc = tcg_doc tc_result hmi = tcg_hmi tc_result return (decl,imports,exports,doc,hmi) - return (Just (HscChecked rdr_module + maybeModGuts <- + if compileToCore then + deSugar hsc_env (ms_location mod_summary) tc_result + else + return Nothing + return (Just (HscChecked rdr_module rnInfo (Just (tcg_binds tc_result, tcg_rdr_env tc_result, - md)))) + md)) + (fmap mg_binds maybeModGuts))) }}}} -- 1.7.10.4