From: Lemmih Date: Sat, 4 Mar 2006 13:27:12 +0000 (+0000) Subject: Comments and esthetical changes. X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=9a32e538207812cefda23dd30d503bd0d886f456 Comments and esthetical changes. --- diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index bbc5a48..bbc8051 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -171,10 +171,10 @@ compile hsc_env mod_summary maybe_old_linkable old_iface mod_index nmods = do = do stub_o <- compileStub dflags' this_mod location return [ DotO stub_o ] - handleMake (NewHscNoRecomp, iface, details) + handleMake (HscNoRecomp, iface, details) = ASSERT (isJust maybe_old_linkable) return (CompOK details iface maybe_old_linkable) - handleMake (NewHscRecomp hasStub, iface, details) + handleMake (HscRecomp hasStub, iface, details) | isHsBoot src_flavour = return (CompOK details iface Nothing) | otherwise @@ -757,13 +757,13 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma case mbResult of Nothing -> throwDyn (PhaseFailed "hsc" (ExitFailure 1)) - Just NewHscNoRecomp + Just HscNoRecomp -> do SysTools.touch dflags' "Touching object file" o_file -- The .o file must have a later modification date -- than the source file (else we wouldn't be in HscNoRecomp) -- but we touch it anyway, to keep 'make' happy (we think). return (StopLn, dflags', Just location4, o_file) - Just (NewHscRecomp hasStub) + Just (HscRecomp hasStub) -> do when hasStub $ do stub_o <- compileStub dflags' mod_name location4 consIORef v_Ld_inputs stub_o diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 46bf3e8..3885bd3 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -168,14 +168,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 +197,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 +227,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 +245,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 +253,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 -> hscCodeGenSimple (\(i, d, g) -> (HscRecomp False, i, d)) _other -> hscCodeGenMake compiler = case ms_hsc_src mod_summary of @@ -268,6 +277,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 +291,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 +308,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 +394,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 +469,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 @@ -478,74 +572,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)