+ let { bomb = panic "hscNoRecomp:OneShot" };
+ return (HscNoRecomp bomb bomb)
+ }
+ | otherwise
+ = do { compilationProgressMsg (hsc_dflags hsc_env) $
+ ("Skipping " ++ showModMsg have_object mod_summary)
+
+ ; new_details <- _scc_ "tcRnIface"
+ typecheckIface hsc_env old_iface ;
+ ; dumpIfaceStats hsc_env
+
+ ; return (HscNoRecomp new_details old_iface)
+ }
+
+------------------------------
+hscRecomp hsc_env msg_act mod_summary
+ have_object maybe_checked_iface
+ = case ms_hsc_src mod_summary of
+ HsSrcFile -> do { front_res <- hscFileFrontEnd hsc_env msg_act mod_summary
+ ; hscBackEnd hsc_env mod_summary maybe_checked_iface front_res }
+
+ HsBootFile -> do { front_res <- hscFileFrontEnd hsc_env msg_act mod_summary
+ ; hscBootBackEnd hsc_env mod_summary maybe_checked_iface front_res }
+
+ ExtCoreFile -> do { front_res <- hscCoreFrontEnd hsc_env msg_act mod_summary
+ ; hscBackEnd hsc_env mod_summary maybe_checked_iface front_res }
+
+hscCoreFrontEnd hsc_env msg_act mod_summary = do {
+ -------------------
+ -- PARSE
+ -------------------
+ ; inp <- readFile (expectJust "hscCoreFrontEnd" (ms_hspp_file mod_summary))
+ ; case parseCore inp 1 of
+ FailP s -> putMsg s{-ToDo: wrong-} >> return Nothing
+ OkP rdr_module -> do {
+
+ -------------------
+ -- RENAME and TYPECHECK
+ -------------------
+ ; (tc_msgs, maybe_tc_result) <- _scc_ "TypeCheck"
+ tcRnExtCore hsc_env rdr_module
+ ; msg_act tc_msgs
+ ; case maybe_tc_result of
+ Nothing -> return Nothing
+ Just mod_guts -> return (Just mod_guts) -- No desugaring to do!
+ }}
+
+
+hscFileFrontEnd hsc_env msg_act mod_summary = do {
+ -------------------
+ -- DISPLAY PROGRESS MESSAGE
+ -------------------
+ let one_shot = isOneShot (ghcMode (hsc_dflags hsc_env))
+ ; let dflags = hsc_dflags hsc_env
+ ; let toInterp = hscTarget dflags == HscInterpreted
+ ; when (not one_shot) $
+ compilationProgressMsg dflags $
+ ("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 (hsc_dflags hsc_env) hspp_file hspp_buf
+
+ ; case maybe_parsed of {
+ Left err -> do { msg_act (unitBag err, emptyBag)
+ ; 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) rdr_module
+
+ ; msg_act 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
+ ; msg_act (warns, emptyBag)
+ ; case maybe_ds_result of
+ Nothing -> return Nothing
+ Just ds_result -> return (Just ds_result)
+ }}}}}
+
+------------------------------
+hscBootBackEnd :: HscEnv -> ModSummary -> Maybe ModIface -> Maybe ModGuts -> IO HscResult
+-- For hs-boot files, there's no code generation to do
+
+hscBootBackEnd hsc_env mod_summary maybe_checked_iface Nothing
+ = return HscFail
+hscBootBackEnd hsc_env mod_summary maybe_checked_iface (Just ds_result)
+ = do { final_iface <- _scc_ "MkFinalIface"
+ mkIface hsc_env (ms_location mod_summary)
+ maybe_checked_iface ds_result
+
+ ; let { final_details = ModDetails { md_types = mg_types ds_result,
+ md_insts = mg_insts ds_result,
+ md_rules = mg_rules ds_result } }
+ -- And the answer is ...
+ ; dumpIfaceStats hsc_env
+
+ ; return (HscRecomp final_details
+ final_iface
+ False False Nothing)
+ }
+
+------------------------------
+hscBackEnd :: HscEnv -> ModSummary -> Maybe ModIface -> Maybe ModGuts -> IO HscResult
+
+hscBackEnd hsc_env mod_summary maybe_checked_iface Nothing
+ = return HscFail
+
+hscBackEnd hsc_env mod_summary maybe_checked_iface (Just ds_result)
+ = do { -- OMITTED:
+ -- ; seqList imported_modules (return ())
+
+ let one_shot = isOneShot (ghcMode (hsc_dflags hsc_env))
+ dflags = hsc_dflags hsc_env
+
+ -------------------
+ -- FLATTENING
+ -------------------
+ ; flat_result <- _scc_ "Flattening"
+ flatten hsc_env ds_result
+
+
+{- TEMP: need to review space-leak fixing here
+ NB: even the code generator can force one of the
+ thunks for constructor arguments, for newtypes in particular
+
+ ; let -- Rule-base accumulated from imported packages
+ pkg_rule_base = eps_rule_base (hsc_EPS hsc_env)
+
+ -- In one-shot mode, ZAP the external package state at
+ -- this point, because we aren't going to need it from
+ -- now on. We keep the name cache, however, because
+ -- tidyCore needs it.
+ pcs_middle
+ | one_shot = pcs_tc{ pcs_EPS = error "pcs_EPS missing" }
+ | otherwise = pcs_tc
+
+ ; pkg_rule_base `seq` pcs_middle `seq` return ()
+-}
+
+ -- alive at this point:
+ -- pcs_middle
+ -- flat_result
+ -- pkg_rule_base
+
+ -------------------
+ -- SIMPLIFY
+ -------------------
+ ; simpl_result <- _scc_ "Core2Core"
+ core2core hsc_env flat_result
+
+ -------------------
+ -- TIDY
+ -------------------
+ ; tidy_result <- _scc_ "CoreTidy"
+ tidyCorePgm hsc_env simpl_result
+
+ -- Emit external core
+ ; emitExternalCore dflags tidy_result
+
+ -- Alive at this point:
+ -- tidy_result, pcs_final
+ -- hsc_env
+
+ -------------------
+ -- BUILD THE NEW ModIface and ModDetails
+ -- and emit external core if necessary
+ -- This has to happen *after* code gen so that the back-end
+ -- info has been set. Not yet clear if it matters waiting
+ -- until after code output
+ ; new_iface <- _scc_ "MkFinalIface"
+ mkIface hsc_env (ms_location mod_summary)
+ maybe_checked_iface tidy_result
+
+ -- Space leak reduction: throw away the new interface if
+ -- we're in one-shot mode; we won't be needing it any
+ -- more.
+ ; final_iface <-
+ if one_shot then return (error "no final iface")
+ else return new_iface
+
+ -- Build the final ModDetails (except in one-shot mode, where
+ -- we won't need this information after compilation).
+ ; final_details <-
+ if one_shot then return (error "no final details")
+ else return $! ModDetails {
+ md_types = mg_types tidy_result,
+ md_insts = mg_insts tidy_result,
+ md_rules = mg_rules tidy_result }
+
+ -------------------
+ -- CONVERT TO STG and COMPLETE CODE GENERATION
+ ; (stub_h_exists, stub_c_exists, maybe_bcos)
+ <- hscCodeGen dflags tidy_result
+
+ -- And the answer is ...
+ ; dumpIfaceStats hsc_env
+
+ ; return (HscRecomp final_details
+ final_iface
+ stub_h_exists stub_c_exists
+ maybe_bcos)
+ }
+
+
+hscFileCheck hsc_env msg_act hspp_file = do {
+ -------------------
+ -- PARSE
+ -------------------
+ ; maybe_parsed <- myParseModule (hsc_dflags hsc_env) hspp_file Nothing
+
+ ; case maybe_parsed of {
+ Left err -> do { msg_act (unitBag err, emptyBag) ;
+ ; return HscFail ;
+ };
+ Right rdr_module -> hscBufferTypecheck hsc_env rdr_module msg_act
+ }}
+
+
+-- Perform static/dynamic checks on the source code in a StringBuffer
+-- This is a temporary solution: it'll read in interface files lazily, whereas
+-- we probably want to use the compilation manager to load in all the modules
+-- in a project.
+hscBufferCheck :: HscEnv -> StringBuffer -> MessageAction -> IO HscResult
+hscBufferCheck hsc_env buffer msg_act = do
+ let loc = mkSrcLoc (mkFastString "*edit*") 1 0
+ showPass (hsc_dflags hsc_env) "Parser"
+ case unP parseModule (mkPState buffer loc (hsc_dflags hsc_env)) of
+ PFailed span err -> do
+ msg_act (emptyBag, unitBag (mkPlainErrMsg span err))
+ return HscFail
+ POk _ rdr_module -> do
+ hscBufferTypecheck hsc_env rdr_module msg_act
+
+hscBufferTypecheck hsc_env rdr_module msg_act = do
+ (tc_msgs, maybe_tc_result) <- _scc_ "Typecheck-Rename"
+ tcRnModule hsc_env HsSrcFile rdr_module
+ msg_act tc_msgs
+ case maybe_tc_result of
+ Nothing -> return (HscChecked rdr_module Nothing)
+ -- space leak on rdr_module!
+ Just r -> return (HscChecked rdr_module (Just r))
+
+
+hscCodeGen dflags
+ ModGuts{ -- This is the last use of the ModGuts in a compilation.
+ -- From now on, we just use the bits we need.
+ mg_module = this_mod,
+ mg_binds = core_binds,
+ mg_types = type_env,
+ mg_dir_imps = dir_imps,
+ mg_foreign = foreign_stubs,
+ mg_deps = dependencies } = do {
+
+ -------------------
+ -- PREPARE FOR CODE GENERATION
+ -- Do saturation and convert to A-normal form
+ prepd_binds <- _scc_ "CorePrep"
+ corePrepPgm dflags core_binds type_env;
+
+ case hscTarget dflags of
+ HscNothing -> return (False, False, Nothing)
+
+ HscInterpreted ->
+#ifdef GHCI
+ do ----------------- Generate byte code ------------------
+ comp_bc <- byteCodeGen dflags prepd_binds type_env
+
+ ------------------ Create f-x-dynamic C-side stuff ---
+ (istub_h_exists, istub_c_exists)
+ <- outputForeignStubs dflags foreign_stubs
+
+ return ( istub_h_exists, istub_c_exists, Just comp_bc )
+#else
+ panic "GHC not compiled with interpreter"
+#endif