From: Tim Chevalier Date: Tue, 25 Dec 2007 20:04:11 +0000 (+0000) Subject: Extend API for compiling to and from Core X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=98c68a1c5b63aadf9c7917274519d95bbe9394d4 Extend API for compiling to and from Core Added API support for compiling Haskell to simplified Core, and for compiling Core to machine code. The latter, especially, should be considered experimental and has only been given cursory testing. Also fixed warnings in DriverPipeline. Merry Christmas. --- diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index 7744e8b..7ecf666 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -378,7 +378,7 @@ data DataConIds -- The 'Nothing' case of DCIds is important -- Not only is this efficient, -- but it also ensures that the wrapper is replaced - -- by the worker (becuase it *is* the worker) + -- by the worker (because it *is* the worker) -- even when there are no args. E.g. in -- f (:) x -- the (:) *is* the worker. diff --git a/compiler/basicTypes/Module.lhs b/compiler/basicTypes/Module.lhs index f6b8b83..9d60247 100644 --- a/compiler/basicTypes/Module.lhs +++ b/compiler/basicTypes/Module.lhs @@ -16,6 +16,7 @@ module Module pprModuleName, moduleNameFS, moduleNameString, + moduleNameSlashes, mkModuleName, mkModuleNameFS, @@ -50,8 +51,8 @@ module Module extendModuleEnvList_C, plusModuleEnv_C, delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv, lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv, - moduleEnvElts, unitModuleEnv, isEmptyModuleEnv, foldModuleEnv, - extendModuleEnv_C, filterModuleEnv, + moduleEnvKeys, moduleEnvElts, unitModuleEnv, isEmptyModuleEnv, + foldModuleEnv, extendModuleEnv_C, filterModuleEnv, -- * ModuleName mappings ModuleNameEnv, @@ -173,6 +174,11 @@ mkModuleName s = ModuleName (mkFastString s) mkModuleNameFS :: FastString -> ModuleName mkModuleNameFS s = ModuleName s + +-- Returns the string version of the module name, with dots replaced by slashes +moduleNameSlashes :: ModuleName -> String +moduleNameSlashes = dots_to_slashes . moduleNameString + where dots_to_slashes = map (\c -> if c == '.' then '/' else c) \end{code} %************************************************************************ @@ -305,6 +311,7 @@ delModuleEnvList :: ModuleEnv a -> [Module] -> ModuleEnv a delModuleEnv :: ModuleEnv a -> Module -> ModuleEnv a plusModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> ModuleEnv a -> ModuleEnv a mapModuleEnv :: (a -> b) -> ModuleEnv a -> ModuleEnv b +moduleEnvKeys :: ModuleEnv a -> [Module] moduleEnvElts :: ModuleEnv a -> [a] isEmptyModuleEnv :: ModuleEnv a -> Bool @@ -329,6 +336,7 @@ lookupWithDefaultModuleEnv = lookupWithDefaultFM mapModuleEnv f = mapFM (\_ v -> f v) mkModuleEnv = listToFM emptyModuleEnv = emptyFM +moduleEnvKeys = keysFM moduleEnvElts = eltsFM unitModuleEnv = unitFM isEmptyModuleEnv = isEmptyFM diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index c6a2ee2..5cc4925 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -1,10 +1,3 @@ -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - ----------------------------------------------------------------------------- -- -- GHC Driver @@ -104,14 +97,9 @@ compile hsc_env summary mod_index nmods mb_old_iface maybe_old_linkable let dflags0 = ms_hspp_opts summary this_mod = ms_mod summary src_flavour = ms_hsc_src summary - - have_object - | Just l <- maybe_old_linkable, isObjectLinkable l = True - | otherwise = False - - let location = ms_location summary - let input_fn = expectJust "compile:hs" (ml_hs_file location) - let input_fnpp = ms_hspp_file summary + location = ms_location summary + input_fn = expectJust "compile:hs" (ml_hs_file location) + input_fnpp = ms_hspp_file summary debugTraceMsg dflags0 2 (text "compile: input file" <+> text input_fnpp) @@ -267,12 +255,12 @@ link :: GhcLink -- interactive or batch -- will succeed. #ifdef GHCI -link LinkInMemory dflags batch_attempt_linking hpt +link LinkInMemory _ _ _ = do -- Not Linking...(demand linker will do the job) return Succeeded #endif -link NoLink dflags batch_attempt_linking hpt +link NoLink _ _ _ = return Succeeded link LinkBinary dflags batch_attempt_linking hpt @@ -308,9 +296,9 @@ link LinkBinary dflags batch_attempt_linking hpt extra_times <- mapM (IO.try . getModificationTime) extra_ld_inputs let other_times = map linkableTime linkables ++ [ t' | Right t' <- extra_times ] - linking_needed - | Left _ <- e_exe_time = True - | Right t <- e_exe_time = any (t <) other_times + linking_needed = case e_exe_time of + Left _ -> True + Right t -> any (t <) other_times if not (dopt Opt_ForceRecomp dflags) && not linking_needed then do debugTraceMsg dflags 2 (text exe_file <+> ptext SLIT("is up to date, linking not required.")) @@ -324,6 +312,7 @@ link LinkBinary dflags batch_attempt_linking hpt let link = case ghcLink dflags of LinkBinary -> linkBinary LinkDynLib -> linkDynLib + other -> panicBadLink other link dflags obj_files pkg_deps debugTraceMsg dflags 3 (text "link: done") @@ -336,6 +325,12 @@ link LinkBinary dflags batch_attempt_linking hpt text " Main.main not exported; not linking.") return Succeeded +-- warning suppression +link other _ _ _ = panicBadLink other + +panicBadLink :: GhcLink -> a +panicBadLink other = panic ("link: GHC not built to link this way: " ++ + show other) -- ----------------------------------------------------------------------------- -- Compile files in one-shot mode. @@ -366,7 +361,7 @@ compileFile dflags stop_phase (src, mb_phase) = do stop_phase' = case stop_phase of As | split -> SplitAs - other -> stop_phase + _ -> stop_phase (_, out_file) <- runPipeline stop_phase' dflags (src, mb_phase) Nothing output @@ -384,6 +379,7 @@ doLink dflags stop_phase o_files NoLink -> return () LinkBinary -> linkBinary dflags o_files link_pkgs LinkDynLib -> linkDynLib dflags o_files [] + other -> panicBadLink other where -- Always link in the haskell98 package for static linking. Other -- packages have to be specified via the -package flag. @@ -658,7 +654,7 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma ; m <- getCoreModuleName input_fn ; return (Nothing, mkModuleName m, [], []) } - other -> do { buf <- hGetStringBuffer input_fn + _ -> do { buf <- hGetStringBuffer input_fn ; (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename `joinFileExt` suff) ; return (Just buf, mod_name, imps, src_imps) } @@ -737,8 +733,6 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma -- Make the ModSummary to hand to hscMain let - unused_field = panic "runPhase:ModSummary field" - -- Some fields are not looked at by hscMain mod_summary = ModSummary { ms_mod = mod, ms_hsc_src = src_flavour, ms_hspp_file = input_fn, @@ -777,13 +771,13 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma ----------------------------------------------------------------------------- -- Cmm phase -runPhase CmmCpp stop dflags basename suff input_fn get_output_fn maybe_loc +runPhase CmmCpp _stop dflags _basename _suff input_fn get_output_fn maybe_loc = do output_fn <- get_output_fn dflags Cmm maybe_loc doCpp dflags False{-not raw-} True{-include CC opts-} input_fn output_fn return (Cmm, dflags, maybe_loc, output_fn) -runPhase Cmm stop dflags basename suff input_fn get_output_fn maybe_loc +runPhase Cmm stop dflags basename _ input_fn get_output_fn maybe_loc = do let hsc_lang = hscMaybeAdjustTarget dflags stop HsSrcFile (hscTarget dflags) let next_phase = hscNextPhase dflags HsSrcFile hsc_lang @@ -805,7 +799,7 @@ runPhase Cmm stop dflags basename suff input_fn get_output_fn maybe_loc -- we don't support preprocessing .c files (with -E) now. Doing so introduces -- way too many hacks, and I can't say I've ever used it anyway. -runPhase cc_phase stop dflags basename suff input_fn get_output_fn maybe_loc +runPhase cc_phase _stop dflags _basename _suff input_fn get_output_fn maybe_loc | cc_phase `eqPhase` Cc || cc_phase `eqPhase` Ccpp || cc_phase `eqPhase` HCc = do let cc_opts = getOpts dflags opt_c hcc = cc_phase `eqPhase` HCc @@ -915,7 +909,7 @@ runPhase cc_phase stop dflags basename suff input_fn get_output_fn maybe_loc ----------------------------------------------------------------------------- -- Mangle phase -runPhase Mangle stop dflags _basename _suff input_fn get_output_fn maybe_loc +runPhase Mangle _stop dflags _basename _suff input_fn get_output_fn maybe_loc = do let mangler_opts = getOpts dflags opt_m #if i386_TARGET_ARCH @@ -941,7 +935,7 @@ runPhase Mangle stop dflags _basename _suff input_fn get_output_fn maybe_loc ----------------------------------------------------------------------------- -- Splitting phase -runPhase SplitMangle stop dflags _basename _suff input_fn get_output_fn maybe_loc +runPhase SplitMangle _stop dflags _basename _suff input_fn _get_output_fn maybe_loc = do -- tmp_pfx is the prefix used for the split .s files -- We also use it as the file to contain the no. of split .s files (sigh) split_s_prefix <- SysTools.newTempName dflags "split" @@ -968,7 +962,7 @@ runPhase SplitMangle stop dflags _basename _suff input_fn get_output_fn maybe_lo ----------------------------------------------------------------------------- -- As phase -runPhase As stop dflags _basename _suff input_fn get_output_fn maybe_loc +runPhase As _stop dflags _basename _suff input_fn get_output_fn maybe_loc = do let as_opts = getOpts dflags opt_a let cmdline_include_paths = includePaths dflags @@ -1000,7 +994,7 @@ runPhase As stop dflags _basename _suff input_fn get_output_fn maybe_loc return (StopLn, dflags, maybe_loc, output_fn) -runPhase SplitAs stop dflags basename _suff _input_fn get_output_fn maybe_loc +runPhase SplitAs _stop dflags _basename _suff _input_fn get_output_fn maybe_loc = do output_fn <- get_output_fn dflags StopLn maybe_loc @@ -1058,7 +1052,9 @@ runPhase SplitAs stop dflags basename _suff _input_fn get_output_fn maybe_loc return (StopLn, dflags, maybe_loc, output_fn) - +-- warning suppression +runPhase other _stop _dflags _basename _suff _input_fn _get_output_fn _maybe_loc = + panic ("runPhase: don't know how to run phase " ++ show other) ----------------------------------------------------------------------------- -- MoveBinary sort-of-phase -- After having produced a binary, move it somewhere else and generate a @@ -1070,6 +1066,7 @@ runPhase SplitAs stop dflags basename _suff _input_fn get_output_fn maybe_loc -- we don't need the generality of a phase (MoveBinary is always -- done after linking and makes only sense in a parallel setup) -- HWL +runPhase_MoveBinary :: DynFlags -> FilePath -> IO Bool runPhase_MoveBinary dflags input_fn = do let sysMan = pgm_sysman dflags @@ -1146,6 +1143,7 @@ mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $ ----------------------------------------------------------------------------- -- Complain about non-dynamic flags in OPTIONS pragmas +checkProcessArgsResult :: [String] -> FilePath -> IO () checkProcessArgsResult flags filename = do when (notNull flags) (throwDyn (ProgramError ( showSDoc (hang (text filename <> char ':') @@ -1300,10 +1298,11 @@ maybeCreateManifest :: DynFlags -> FilePath -- filename of executable -> IO [FilePath] -- extra objects to embed, maybe -maybeCreateManifest dflags exe_filename = do #ifndef mingw32_TARGET_OS +maybeCreateManifest _ _ = do return [] #else +maybeCreateManifest dflags exe_filename = do if not (dopt Opt_GenManifest dflags) then return [] else do let manifest_filename = exe_filename `joinFileExt` "manifest" @@ -1324,7 +1323,7 @@ maybeCreateManifest dflags exe_filename = do " \n"++ "\n" - -- Windows will fine the manifest file if it is named foo.exe.manifest. + -- Windows will find the manifest file if it is named foo.exe.manifest. -- However, for extra robustness, and so that we can move the binary around, -- we can embed the manifest in the binary itself using windres: if not (dopt Opt_EmbedManifest dflags) then return [] else do @@ -1335,7 +1334,7 @@ maybeCreateManifest dflags exe_filename = do writeFile rc_filename $ "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n" -- magic numbers :-) - -- show is a bit hackish above, but we need to esacpe the + -- show is a bit hackish above, but we need to escape the -- backslashes in the path. let wr_opts = getOpts dflags opt_windres @@ -1354,8 +1353,6 @@ maybeCreateManifest dflags exe_filename = do linkDynLib :: DynFlags -> [String] -> [PackageId] -> IO () linkDynLib dflags o_files dep_packages = do let verb = getVerbFlag dflags - let static = opt_Static - let no_hs_main = dopt Opt_NoHsMain dflags let o_file = outputFile dflags pkg_lib_paths <- getPackageLibraryPath dflags dep_packages @@ -1519,8 +1516,10 @@ doCpp dflags raw include_cc_opts input_fn output_fn = do , SysTools.FileOption "" output_fn ]) +cHaskell1Version :: String cHaskell1Version = "5" -- i.e., Haskell 98 +hsSourceCppOpts :: [String] -- Default CPP defines in Haskell source hsSourceCppOpts = [ "-D__HASKELL1__="++cHaskell1Version @@ -1534,8 +1533,8 @@ hsSourceCppOpts = -- Misc. hscNextPhase :: DynFlags -> HscSource -> HscTarget -> Phase -hscNextPhase dflags HsBootFile hsc_lang = StopLn -hscNextPhase dflags other hsc_lang = +hscNextPhase _ HsBootFile _ = StopLn +hscNextPhase dflags _ hsc_lang = case hsc_lang of HscC -> HCc HscAsm | dopt Opt_SplitObjs dflags -> SplitMangle @@ -1546,7 +1545,7 @@ hscNextPhase dflags other hsc_lang = hscMaybeAdjustTarget :: DynFlags -> Phase -> HscSource -> HscTarget -> HscTarget -hscMaybeAdjustTarget dflags stop other current_hsc_lang +hscMaybeAdjustTarget dflags stop _ current_hsc_lang = hsc_lang where keep_hc = dopt Opt_KeepHcFiles dflags @@ -1560,5 +1559,6 @@ hscMaybeAdjustTarget dflags stop other current_hsc_lang -- otherwise, stick to the plan | otherwise = current_hsc_lang +v_Split_info :: IORef (String, Int) GLOBAL_VAR(v_Split_info, ("",0), (String,Int)) -- The split prefix and number of files diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index cae2afb..07ed33f 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -436,7 +436,7 @@ data GhcLink -- What to do in the link step, if there is one | LinkBinary -- Link object code into a binary | LinkInMemory -- Use the in-memory dynamic linker | LinkDynLib -- Link objects into a dynamic lib (DLL on Windows, DSO on ELF platforms) - deriving Eq + deriving (Eq, Show) isNoLink :: GhcLink -> Bool isNoLink NoLink = True diff --git a/compiler/main/Finder.lhs b/compiler/main/Finder.lhs index 6e2b11d..206d118 100644 --- a/compiler/main/Finder.lhs +++ b/compiler/main/Finder.lhs @@ -12,6 +12,7 @@ module Finder ( findHomeModule, mkHomeModLocation, mkHomeModLocation2, + mkHiOnlyModLocation, addHomeModuleToFinder, uncacheModule, mkStubPaths, @@ -21,6 +22,7 @@ module Finder ( cannotFindModule, cannotFindInterface, + ) where #include "HsVersions.h" @@ -337,7 +339,7 @@ searchPathExts paths mod exts return result where - basename = dots_to_slashes (moduleNameString (moduleName mod)) + basename = moduleNameSlashes (moduleName mod) to_search :: [(FilePath, IO ModLocation)] to_search = [ (file, fn path basename) @@ -387,7 +389,7 @@ mkHomeModLocationSearched dflags mod suff path basename = do -- (b) and (c): "." -- -- src_basename --- (a): dots_to_slashes (moduleNameUserString mod) +-- (a): (moduleNameSlashes mod) -- (b) and (c): The filename of the source file, minus its extension -- -- ext @@ -404,7 +406,7 @@ mkHomeModLocation2 :: DynFlags -> String -- Suffix -> IO ModLocation mkHomeModLocation2 dflags mod src_basename ext = do - let mod_basename = dots_to_slashes (moduleNameString mod) + let mod_basename = moduleNameSlashes mod obj_fn <- mkObjPath dflags src_basename mod_basename hi_fn <- mkHiPath dflags src_basename mod_basename @@ -478,7 +480,7 @@ mkStubPaths dflags mod location = let stubdir = stubDir dflags - mod_basename = dots_to_slashes (moduleNameString mod) + mod_basename = moduleNameSlashes mod src_basename = basenameOf (expectJust "mkStubPaths" (ml_hs_file location)) @@ -530,12 +532,6 @@ findObjectLinkable mod obj_fn obj_time = do else return (LM obj_time mod [DotO obj_fn]) -- ----------------------------------------------------------------------------- --- Utils - -dots_to_slashes :: String -> String -dots_to_slashes = map (\c -> if c == '.' then '/' else c) - --- ----------------------------------------------------------------------------- -- Error messages cannotFindModule :: DynFlags -> ModuleName -> FindResult -> SDoc diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 967daf3..c44cc83 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -41,7 +41,8 @@ module GHC ( workingDirectoryChanged, checkModule, checkAndLoadModule, CheckedModule(..), TypecheckedSource, ParsedSource, RenamedSource, - compileToCore, compileToCoreModule, + compileToCore, compileToCoreModule, compileToCoreSimplified, + compileCoreToObj, -- * Parsing Haddock comments parseHaddockComment, @@ -229,9 +230,12 @@ import FunDeps import DataCon import Name hiding ( varName ) import OccName ( parenSymOcc ) -import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr ) +import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr, + emptyInstEnv ) +import FamInstEnv ( emptyFamInstEnv ) import SrcLoc import CoreSyn +import TidyPgm import DriverPipeline import DriverPhases ( HscSource(..), Phase(..), isHaskellSrcFilename, startPhase ) import HeaderInfo ( getImports, getOptions ) @@ -263,13 +267,14 @@ import HaddockParse import HaddockLex ( tokenise ) import Control.Concurrent -import System.Directory ( getModificationTime, doesFileExist ) +import System.Directory ( getModificationTime, doesFileExist, + getCurrentDirectory ) import Data.Maybe import Data.List import qualified Data.List as List import Control.Monad import System.Exit ( exitWith, ExitCode(..) ) -import System.Time ( ClockTime ) +import System.Time ( ClockTime, getClockTime ) import Control.Exception as Exception hiding (handle) import Data.IORef import System.IO @@ -777,7 +782,7 @@ data CheckedModule = renamedSource :: Maybe RenamedSource, typecheckedSource :: Maybe TypecheckedSource, checkedModuleInfo :: Maybe ModuleInfo, - coreModule :: Maybe CoreModule + coreModule :: Maybe ModGuts } -- ToDo: improvements that could be made here: -- if the module succeeded renaming but not typechecking, @@ -867,12 +872,6 @@ checkModule_ ref ms compile_to_core load then deSugarModule hsc_env ms tcg else return Nothing - let mb_core = fmap (\ mg -> - CoreModule { cm_module = mg_module mg, - cm_types = mg_types mg, - cm_binds = mg_binds mg }) - mb_guts - -- If we are loading this module so that we can typecheck -- dependent modules, generate an interface and stuff it -- all in the HomePackageTable. @@ -890,7 +889,7 @@ checkModule_ ref ms compile_to_core load renamedSource = rn_info, typecheckedSource = Just tc_binds, checkedModuleInfo = Just minf, - coreModule = mb_core })) + coreModule = mb_guts })) -- | This is the way to get access to the Core bindings corresponding -- to a module. 'compileToCore' invokes 'checkModule' to parse, typecheck, and @@ -898,7 +897,90 @@ checkModule_ ref ms compile_to_core load -- the module name, type declarations, and function declarations) if -- successful. compileToCoreModule :: Session -> FilePath -> IO (Maybe CoreModule) -compileToCoreModule session fn = do +compileToCoreModule = compileCore False + +-- | Like compileToCoreModule, but invokes the simplifier, so +-- as to return simplified and tidied Core. +compileToCoreSimplified :: Session -> FilePath -> IO (Maybe CoreModule) +compileToCoreSimplified = compileCore True + +-- | 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 + +-- | Takes a CoreModule and compiles the bindings therein +-- to object code. The first argument is a bool flag indicating +-- whether to run the simplifier. +-- The resulting .o, .hi, and executable files, if any, are stored in the +-- current directory, and named according to the module name. +-- Returns True iff compilation succeeded. +-- This has only so far been tested with a single self-contained module. +compileCoreToObj :: Bool -> Session -> CoreModule -> IO Bool +compileCoreToObj simplify session cm@(CoreModule{ cm_module = mName }) = do + hscEnv <- sessionHscEnv session + dflags <- getSessionDynFlags session + currentTime <- getClockTime + cwd <- getCurrentDirectory + modLocation <- mkHiOnlyModLocation dflags (hiSuf dflags) cwd + ((moduleNameSlashes . moduleName) mName) + + let modSummary = ModSummary { ms_mod = mName, + ms_hsc_src = ExtCoreFile, + ms_location = modLocation, + -- By setting the object file timestamp to Nothing, + -- we always force recompilation, which is what we + -- want. (Thus it doesn't matter what the timestamp + -- for the (nonexistent) source file is.) + ms_hs_date = currentTime, + ms_obj_date = Nothing, + -- Only handling the single-module case for now, so no imports. + ms_srcimps = [], + ms_imps = [], + -- No source file + ms_hspp_file = "", + ms_hspp_opts = dflags, + ms_hspp_buf = Nothing + } + + mbHscResult <- evalComp + ((if simplify then hscSimplify else return) (mkModGuts cm) + >>= hscNormalIface >>= hscWriteIface >>= hscOneShot) + (CompState{ compHscEnv=hscEnv, + compModSummary=modSummary, + compOldIface=Nothing}) + return $ isJust mbHscResult + +-- Makes a "vanilla" ModGuts. +mkModGuts :: CoreModule -> ModGuts +mkModGuts coreModule = ModGuts { + mg_module = cm_module coreModule, + mg_boot = False, + mg_exports = [], + mg_deps = noDependencies, + mg_dir_imps = emptyModuleEnv, + mg_used_names = emptyNameSet, + mg_rdr_env = emptyGlobalRdrEnv, + mg_fix_env = emptyFixityEnv, + mg_types = emptyTypeEnv, + mg_insts = [], + mg_fam_insts = [], + mg_rules = [], + mg_binds = cm_binds coreModule, + mg_foreign = NoStubs, + mg_deprecs = NoDeprecs, + mg_hpc_info = emptyHpcInfo False, + mg_modBreaks = emptyModBreaks, + mg_vect_info = noVectInfo, + mg_inst_env = emptyInstEnv, + mg_fam_inst_env = emptyFamInstEnv +} + +compileCore :: Bool -> Session -> FilePath -> IO (Maybe CoreModule) +compileCore simplify session fn = do -- First, set the target to the desired filename target <- guessTarget fn Nothing addTarget session target @@ -916,17 +998,34 @@ compileToCoreModule session fn = do maybeCheckedModule <- checkModule session mod True case maybeCheckedModule of Nothing -> return Nothing - Just checkedMod -> return $ coreModule checkedMod + Just checkedMod -> (liftM $ fmap gutsToCoreModule) $ + case (coreModule checkedMod) of + Just mg | simplify -> (sessionHscEnv session) + -- If simplify is true: simplify (hscSimplify), + -- then tidy (tidyProgram). + >>= \ hscEnv -> evalComp (hscSimplify mg) + (CompState{ compHscEnv=hscEnv, + compModSummary=modSummary, + compOldIface=Nothing}) + >>= (tidyProgram hscEnv) + >>= (return . Just . Left) + Just guts -> return $ Just $ Right guts + Nothing -> return Nothing Nothing -> panic "compileToCoreModule: target FilePath not found in\ module dependency graph" + where -- two versions, based on whether we simplify (thus run tidyProgram, + -- which returns a (CgGuts, ModDetails) pair, or not (in which case + -- we just have a ModGuts. + gutsToCoreModule :: Either (CgGuts, ModDetails) ModGuts -> CoreModule + gutsToCoreModule (Left (cg, md)) = CoreModule { + cm_module = cg_module cg, cm_types = md_types md, + cm_imports = cg_dir_imps cg, cm_binds = cg_binds cg + } + gutsToCoreModule (Right mg) = CoreModule { + cm_module = mg_module mg, cm_types = mg_types mg, + cm_imports = moduleEnvKeys (mg_dir_imps mg), cm_binds = mg_binds mg + } --- | 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 diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 0e9d7ba..8176601 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -8,6 +8,10 @@ module HscMain ( newHscEnv, hscCmmFile , hscParseIdentifier + , hscSimplify + , evalComp + , hscNormalIface, hscWriteIface, hscOneShot + , CompState (..) #ifdef GHCI , hscStmt, hscTcExpr, hscKcType , compileExpr diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 5e6a33e..7f7fab8 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -284,7 +284,7 @@ lookupIfaceByModule dflags hpt pit mod -- (a) In OneShot mode, even home-package modules accumulate in the PIT -- (b) Even in Batch (--make) mode, there is *one* case where a home-package -- module is in the PIT, namely GHC.Prim when compiling the base package. --- We could eliminate (b) if we wanted, by making GHC.Prim belong to a packake +-- We could eliminate (b) if we wanted, by making GHC.Prim belong to a package -- of its own, but it doesn't seem worth the bother. \end{code} @@ -560,7 +560,9 @@ data CoreModule -- Type environment for types declared in this module cm_types :: !TypeEnv, -- Declarations - cm_binds :: [CoreBind] + cm_binds :: [CoreBind], + -- Imports + cm_imports :: ![Module] } instance Outputable CoreModule where