diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index 7744e8bb546a1c40cb833c9dda2ea092329b6296..7ecf666014e52d0cf8e7b847fef46aef47fcf5c3 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 f6b8b8342a7021e93e2cc09e3682567011b9825f..9d60247b55c69eaa0b94531c350e273aa1aa583b 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 c6a2ee292a0f2d57a464410e58b4fd1992f048fb..5cc492596b7a2818fde84203f228b771e547496c 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 cae2afb5a496a13422ccb0be29bc9db197818418..07ed33f596b6e0244bfd867a89703b75ed6f7fce 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 6e2b11d0257fc0734ea711de682b2d538311f055..206d118d6e92aabf31f98cc32abe09e1d5d6ad0b 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)) @@ -529,12 +531,6 @@ findObjectLinkable mod obj_fn obj_time = do then return (LM obj_time mod [DotO obj_fn, DotO stub_fn]) 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 diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 967daf35404cd4d7ce794aa2ebe6376d50fe2795..c44cc83541839aedb8ad19a4b5fc20991fa077c0 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 0e9d7ba8c69c01b79d5acaf0a6f04516e6ba3e26..81766015898fbaa9a9ee47460f55e113cc2aea85 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 5e6a33e9ac1da9a96cf88b3cc8739f375309ff1e..7f7fab8635e34950cebc5f8fc65d4ad254a6858a 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