X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Fmain%2FHscMain.lhs;h=124d9f0803ff22ed6a40824f9f6cfce7cbe13e8e;hb=3c96346b3685f83885cea7906b0dbc536d7695f6;hp=46bf3e8f7aaebf432528c4b62180bba01fdcf6e1;hpb=e5ea30e69a99b71fbd7045daefdf2cbf66c659d4;p=ghc-hetmet.git diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 46bf3e8..124d9f0 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -58,9 +58,9 @@ import IfaceEnv ( initNameCache ) import LoadIface ( ifaceStats, initExternalPackageState ) import PrelInfo ( wiredInThings, basicKnownKeyNames ) import MkIface ( checkOldIface, mkIface, writeIfaceFile ) -import Desugar +import Desugar ( deSugar ) import Flattening ( flatten ) -import SimplCore +import SimplCore ( core2core ) import TidyPgm ( tidyProgram, mkBootModDetails ) import CorePrep ( corePrepPgm ) import CoreToStg ( coreToStg ) @@ -74,7 +74,6 @@ import CodeOutput ( codeOutput ) import DynFlags import ErrUtils -import Util import UniqSupply ( mkSplitUniqSupply ) import Outputable @@ -87,7 +86,6 @@ import FastString import Maybes ( expectJust ) import Bag ( unitBag ) import Monad ( when ) -import Maybe ( isJust ) import IO import DATA_IOREF ( newIORef, readIORef ) \end{code} @@ -168,14 +166,16 @@ data HscChecked (Maybe (LHsBinds Id, GlobalRdrEnv, ModDetails)) +-- Status of a compilation to hard-code or nothing. data HscStatus - = NewHscNoRecomp - | NewHscRecomp Bool -- Has stub files. - -- This is a hack. We can't compile C files here - -- since it's done in DriverPipeline. For now we - -- just return True if we want the caller to compile - -- it for us. - + = HscNoRecomp + | HscRecomp Bool -- Has stub files. + -- This is a hack. We can't compile C files here + -- since it's done in DriverPipeline. For now we + -- just return True if we want the caller to compile + -- it for us. + +-- Status of a compilation to byte-code. data InteractiveStatus = InteractiveNoRecomp | InteractiveRecomp Bool -- Same as HscStatus @@ -195,6 +195,9 @@ type Compiler result = HscEnv -> IO (Maybe result) +-- This functions checks if recompilation is necessary and +-- then combines the FrontEnd, BackEnd and CodeGen to a +-- working compiler. hscMkCompiler :: NoRecomp result -- What to do when recompilation isn't required. -> FrontEnd core -> BackEnd core prepCore @@ -222,11 +225,15 @@ hscMkCompiler norecomp frontend backend codegen result <- codegen hsc_env mod_summary prepCore return (Just result) +-------------------------------------------------------------- +-- Compilers +-------------------------------------------------------------- + -- Compile Haskell, boot and extCore in OneShot mode. hscCompileOneShot :: Compiler HscStatus hscCompileOneShot hsc_env mod_summary = compiler hsc_env mod_summary - where mkComp = hscMkCompiler (norecompOneShot NewHscNoRecomp) + where mkComp = hscMkCompiler (norecompOneShot HscNoRecomp) compiler = case ms_hsc_src mod_summary of ExtCoreFile @@ -236,7 +243,7 @@ hscCompileOneShot hsc_env mod_summary = -> mkComp hscFileFrontEnd hscNewBackEnd hscCodeGenOneShot HsBootFile -> mkComp hscFileFrontEnd hscNewBootBackEnd - (hscCodeGenConst (NewHscRecomp False)) + (hscCodeGenConst (HscRecomp False)) -- Compile Haskell, boot and extCore in --make mode. hscCompileMake :: Compiler (HscStatus, ModIface, ModDetails) @@ -244,7 +251,7 @@ hscCompileMake hsc_env mod_summary = compiler hsc_env mod_summary where mkComp = hscMkCompiler norecompMake backend = case hscTarget (hsc_dflags hsc_env) of - HscNothing -> hscCodeGenSimple (\(i, d, g) -> (NewHscRecomp False, i, d)) + HscNothing -> hscCodeGenNothing _other -> hscCodeGenMake compiler = case ms_hsc_src mod_summary of @@ -268,6 +275,10 @@ hscCompileInteractive hsc_env mod_summary = bootErrorMsg = "Compiling a HsBootFile to bytecode doesn't make sense. " ++ "Use 'hscCompileMake' instead." +-------------------------------------------------------------- +-- NoRecomp handlers +-------------------------------------------------------------- + norecompOneShot :: a -> NoRecomp a norecompOneShot a hsc_env mod_summary have_object old_iface @@ -278,7 +289,7 @@ norecompOneShot a hsc_env mod_summary return a norecompMake :: NoRecomp (HscStatus, ModIface, ModDetails) -norecompMake = norecompWorker NewHscNoRecomp +norecompMake = norecompWorker HscNoRecomp norecompInteractive :: NoRecomp (InteractiveStatus, ModIface, ModDetails) norecompInteractive = norecompWorker InteractiveNoRecomp @@ -295,6 +306,83 @@ norecompWorker a hsc_env mod_summary have_object dumpIfaceStats hsc_env return (a, old_iface, new_details) +-------------------------------------------------------------- +-- FrontEnds +-------------------------------------------------------------- + +hscCoreFrontEnd :: FrontEnd ModGuts +hscCoreFrontEnd hsc_env mod_summary mb_mod_index = do { + ------------------- + -- PARSE + ------------------- + ; inp <- readFile (expectJust "hscCoreFrontEnd" (ms_hspp_file mod_summary)) + ; case parseCore inp 1 of + FailP s -> do errorMsg (hsc_dflags hsc_env) (text s{-ToDo: wrong-}) + return Nothing + OkP rdr_module -> do { + + ------------------- + -- RENAME and TYPECHECK + ------------------- + ; (tc_msgs, maybe_tc_result) <- {-# SCC "TypeCheck" #-} + tcRnExtCore hsc_env rdr_module + ; printErrorsAndWarnings (hsc_dflags hsc_env) tc_msgs + ; case maybe_tc_result of + Nothing -> return Nothing + Just mod_guts -> return (Just mod_guts) -- No desugaring to do! + }} + +hscFileFrontEnd :: FrontEnd ModGuts +hscFileFrontEnd hsc_env mod_summary mb_mod_index = do { + ------------------- + -- DISPLAY PROGRESS MESSAGE + ------------------- + ; let dflags = hsc_dflags hsc_env + one_shot = isOneShot (ghcMode dflags) + toInterp = hscTarget dflags == HscInterpreted + ; when (not one_shot) $ + compilationProgressMsg dflags $ + (showModuleIndex mb_mod_index ++ + "Compiling " ++ showModMsg (not toInterp) mod_summary) + + ------------------- + -- PARSE + ------------------- + ; let hspp_file = expectJust "hscFileFrontEnd" (ms_hspp_file mod_summary) + hspp_buf = ms_hspp_buf mod_summary + + ; maybe_parsed <- myParseModule dflags hspp_file hspp_buf + + ; case maybe_parsed of { + Left err -> do { printBagOfErrors dflags (unitBag err) + ; return Nothing } ; + Right rdr_module -> do { + + ------------------- + -- RENAME and TYPECHECK + ------------------- + (tc_msgs, maybe_tc_result) + <- {-# SCC "Typecheck-Rename" #-} + tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module + + ; printErrorsAndWarnings dflags tc_msgs + ; case maybe_tc_result of { + Nothing -> return Nothing ; + Just tc_result -> do { + + ------------------- + -- DESUGAR + ------------------- + ; (warns, maybe_ds_result) <- {-# SCC "DeSugar" #-} + deSugar hsc_env tc_result + ; printBagOfWarnings dflags warns + ; return maybe_ds_result + }}}}} + +-------------------------------------------------------------- +-- BackEnds +-------------------------------------------------------------- + hscNewBootBackEnd :: BackEnd ModGuts (HscStatus, ModIface, ModDetails) hscNewBootBackEnd hsc_env mod_summary maybe_old_iface ds_result = do details <- mkBootModDetails hsc_env ds_result @@ -304,7 +392,7 @@ hscNewBootBackEnd hsc_env mod_summary maybe_old_iface ds_result writeIfaceFile hsc_env (ms_location mod_summary) new_iface no_change -- And the answer is ... dumpIfaceStats hsc_env - return (NewHscRecomp False, new_iface, details) + return (HscRecomp False, new_iface, details) hscNewBackEnd :: BackEnd ModGuts (ModIface, ModDetails, CgGuts) hscNewBackEnd hsc_env mod_summary maybe_old_iface ds_result @@ -379,22 +467,26 @@ hscNewBackEnd hsc_env mod_summary maybe_old_iface ds_result ; return (new_iface, details, cg_guts) } +-------------------------------------------------------------- +-- Code generators +-------------------------------------------------------------- + -- Don't output any code. hscCodeGenNothing :: CodeGen (ModIface, ModDetails, CgGuts) (HscStatus, ModIface, ModDetails) hscCodeGenNothing hsc_env mod_summary (iface, details, cgguts) - = return (NewHscRecomp False, iface, details) + = return (HscRecomp False, iface, details) -- Generate code and return both the new ModIface and the ModDetails. hscCodeGenMake :: CodeGen (ModIface, ModDetails, CgGuts) (HscStatus, ModIface, ModDetails) hscCodeGenMake hsc_env mod_summary (iface, details, cgguts) = do hasStub <- hscCodeGenCompile hsc_env mod_summary cgguts - return (NewHscRecomp hasStub, iface, details) + return (HscRecomp hasStub, iface, details) -- Here we don't need the ModIface and ModDetails anymore. hscCodeGenOneShot :: CodeGen (ModIface, ModDetails, CgGuts) HscStatus hscCodeGenOneShot hsc_env mod_summary (_, _, cgguts) = do hasStub <- hscCodeGenCompile hsc_env mod_summary cgguts - return (NewHscRecomp hasStub) + return (HscRecomp hasStub) hscCodeGenCompile :: CodeGen CgGuts Bool hscCodeGenCompile hsc_env mod_summary cgguts @@ -409,7 +501,6 @@ hscCodeGenCompile hsc_env mod_summary cgguts cg_dep_pkgs = dependencies } = cgguts dflags = hsc_dflags hsc_env location = ms_location mod_summary - modName = ms_mod mod_summary data_tycons = filter isDataTyCon tycons -- cg_tycons includes newtypes, for the benefit of External Core, -- but we don't generate any code for newtypes @@ -437,9 +528,6 @@ hscCodeGenCompile hsc_env mod_summary cgguts hscCodeGenIdentity :: CodeGen a a hscCodeGenIdentity hsc_env mod_summary a = return a -hscCodeGenSimple :: (a -> b) -> CodeGen a b -hscCodeGenSimple fn hsc_env mod_summary a = return (fn a) - hscCodeGenConst :: b -> CodeGen a b hscCodeGenConst b hsc_env mod_summary a = return b @@ -457,7 +545,6 @@ hscCodeGenInteractive hsc_env mod_summary (iface, details, cgguts) cg_dep_pkgs = dependencies } = cgguts dflags = hsc_dflags hsc_env location = ms_location mod_summary - modName = ms_mod mod_summary data_tycons = filter isDataTyCon tycons -- cg_tycons includes newtypes, for the benefit of External Core, -- but we don't generate any code for newtypes @@ -478,74 +565,6 @@ hscCodeGenInteractive hsc_env mod_summary (iface, details, cgguts) #endif -hscCoreFrontEnd :: FrontEnd ModGuts -hscCoreFrontEnd hsc_env mod_summary mb_mod_index = do { - ------------------- - -- PARSE - ------------------- - ; inp <- readFile (expectJust "hscCoreFrontEnd" (ms_hspp_file mod_summary)) - ; case parseCore inp 1 of - FailP s -> errorMsg (hsc_dflags hsc_env) (text s{-ToDo: wrong-}) >> return Nothing - OkP rdr_module -> do { - - ------------------- - -- RENAME and TYPECHECK - ------------------- - ; (tc_msgs, maybe_tc_result) <- {-# SCC "TypeCheck" #-} - tcRnExtCore hsc_env rdr_module - ; printErrorsAndWarnings (hsc_dflags hsc_env) tc_msgs - ; case maybe_tc_result of - Nothing -> return Nothing - Just mod_guts -> return (Just mod_guts) -- No desugaring to do! - }} - -hscFileFrontEnd :: FrontEnd ModGuts -hscFileFrontEnd hsc_env mod_summary mb_mod_index = do { - ------------------- - -- DISPLAY PROGRESS MESSAGE - ------------------- - ; let dflags = hsc_dflags hsc_env - one_shot = isOneShot (ghcMode dflags) - toInterp = hscTarget dflags == HscInterpreted - ; when (not one_shot) $ - compilationProgressMsg dflags $ - (showModuleIndex mb_mod_index ++ - "Compiling " ++ showModMsg (not toInterp) mod_summary) - - ------------------- - -- PARSE - ------------------- - ; let hspp_file = expectJust "hscFileFrontEnd" (ms_hspp_file mod_summary) - hspp_buf = ms_hspp_buf mod_summary - - ; maybe_parsed <- myParseModule dflags hspp_file hspp_buf - - ; case maybe_parsed of { - Left err -> do { printBagOfErrors dflags (unitBag err) - ; return Nothing } ; - Right rdr_module -> do { - - ------------------- - -- RENAME and TYPECHECK - ------------------- - (tc_msgs, maybe_tc_result) - <- {-# SCC "Typecheck-Rename" #-} - tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module - - ; printErrorsAndWarnings dflags tc_msgs - ; case maybe_tc_result of { - Nothing -> return Nothing ; - Just tc_result -> do { - - ------------------- - -- DESUGAR - ------------------- - ; (warns, maybe_ds_result) <- {-# SCC "DeSugar" #-} - deSugar hsc_env tc_result - ; printBagOfWarnings dflags warns - ; return maybe_ds_result - }}}}} - ------------------------------ hscFileCheck :: HscEnv -> ModSummary -> IO (Maybe HscChecked)