- Nothing -> do { hPutStrLn stderr "Typechecked failed"
- ; return (HscFail pcs_rn) } ;
- Just tc_result -> do {
-
- let pcs_tc = tc_pcs tc_result
- env_tc = tc_env tc_result
- local_insts = tc_insts tc_result
- ;
- -- DESUGAR, SIMPLIFY, TIDY-CORE
- -- We grab the the unfoldings at this point.
- (tidy_binds, orphan_rules, foreign_stuff)
- <- dsThenSimplThenTidy dflags (pcs_rules pcs_tc) this_mod tc_result hst
- ;
- -- CONVERT TO STG
- (stg_binds, oa_tidy_binds, cost_centre_info, top_level_ids)
- <- myCoreToStg dflags this_mod tidy_binds
- ;
- -- cook up a new ModDetails now we (finally) have all the bits
- let new_details = mkModDetails env_tc local_insts tidy_binds
- top_level_ids orphan_rules
- ;
- -- and the final interface
- final_iface
- <- mkFinalIface dflags location maybe_checked_iface new_iface new_details
- ;
- -- do the rest of code generation/emission
- (maybe_stub_h_filename, maybe_stub_c_filename, maybe_ibinds)
- <- restOfCodeGeneration dflags toInterp this_mod
- (map ideclName (hsModuleImports rdr_module))
- cost_centre_info foreign_stuff env_tc stg_binds oa_tidy_binds
- hit (pcs_PIT pcs_tc)
- ;
- -- and the answer is ...
- return (HscOK new_details (Just final_iface)
- maybe_stub_h_filename maybe_stub_c_filename
- maybe_ibinds pcs_tc)
- }}}}}}}
-
-
-
-mkFinalIface dflags location maybe_old_iface new_iface new_details
- = case completeIface maybe_old_iface new_iface new_details of
- (new_iface, Nothing) -- no change in the interfacfe
- -> do if dopt Opt_D_dump_hi_diffs dflags then
- printDump (text "INTERFACE UNCHANGED")
- else return ()
- return new_iface
- (new_iface, Just sdoc)
- -> do dumpIfSet_dyn dflags Opt_D_dump_hi_diffs "NEW INTERFACE" sdoc
- -- Write the interface file
- writeIface (unJust (ml_hi_file location) "hscRecomp:hi") new_iface
- return new_iface
+ Nothing -> return (HscFail pcs_tc);
+ Just new_details ->
+
+ return (HscNoRecomp pcs_tc new_details old_iface)
+ }}
+
+hscRecomp hsc_env pcs_ch have_object
+ mod location maybe_checked_iface
+ = do {
+ -- what target are we shooting for?
+ ; let one_shot = hsc_mode hsc_env == OneShot
+ ; let dflags = hsc_dflags hsc_env
+ ; let toInterp = dopt_HscLang dflags == HscInterpreted
+ ; let toCore = isJust (ml_hs_file location) &&
+ isExtCore_file (fromJust (ml_hs_file location))
+
+ ; when (not one_shot && verbosity dflags >= 1) $
+ hPutStrLn stderr ("Compiling " ++
+ showModMsg (not toInterp) mod location);
+
+ ; front_res <- if toCore then
+ hscCoreFrontEnd hsc_env pcs_ch location
+ else
+ hscFrontEnd hsc_env pcs_ch location
+
+ ; case front_res of
+ Left flure -> return flure;
+ Right (pcs_tc, ds_result) -> do {
+
+
+ -- OMITTED:
+ -- ; seqList imported_modules (return ())
+
+ -------------------
+ -- FLATTENING
+ -------------------
+ ; flat_result <- _scc_ "Flattening"
+ flatten hsc_env pcs_tc ds_result
+
+
+ ; let -- Rule-base accumulated from imported packages
+ pkg_rule_base = eps_rule_base (pcs_EPS pcs_tc)
+
+ -- 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 pkg_rule_base flat_result
+
+ -------------------
+ -- TIDY
+ -------------------
+ ; (pcs_simpl, tidy_result)
+ <- _scc_ "CoreTidy"
+ tidyCorePgm dflags pcs_middle simpl_result
+
+ -- ZAP the persistent compiler state altogether now if we're
+ -- in one-shot mode, to save space.
+ ; pcs_final <- if one_shot then return (error "pcs_final missing")
+ else return pcs_simpl
+
+ ; 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 location
+ 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)
+ <- hscBackEnd dflags tidy_result
+
+ -- and the answer is ...
+ ; return (HscRecomp pcs_final
+ final_details
+ final_iface
+ stub_h_exists stub_c_exists
+ maybe_bcos)
+ }}
+
+hscCoreFrontEnd hsc_env pcs_ch location = do {
+ -------------------
+ -- PARSE
+ -------------------
+ ; inp <- readFile (expectJust "hscCoreFrontEnd:hspp" (ml_hspp_file location))
+ ; case parseCore inp 1 of
+ FailP s -> hPutStrLn stderr s >> return (Left (HscFail pcs_ch));
+ OkP rdr_module -> do {
+
+ -------------------
+ -- RENAME and TYPECHECK
+ -------------------
+ ; (pcs_tc, maybe_tc_result) <- _scc_ "TypeCheck"
+ tcRnExtCore hsc_env pcs_ch rdr_module
+ ; case maybe_tc_result of {
+ Nothing -> return (Left (HscFail pcs_tc));
+ Just mod_guts -> return (Right (pcs_tc, mod_guts))
+ -- No desugaring to do!
+ }}}
+
+
+hscFrontEnd hsc_env pcs_ch location = do {
+ -------------------
+ -- PARSE
+ -------------------
+ ; maybe_parsed <- myParseModule (hsc_dflags hsc_env)
+ (expectJust "hscFrontEnd:hspp" (ml_hspp_file location))
+
+ ; case maybe_parsed of {
+ Nothing -> return (Left (HscFail pcs_ch));
+ Just rdr_module -> do {
+
+ -------------------
+ -- RENAME and TYPECHECK
+ -------------------
+ ; (pcs_tc, maybe_tc_result) <- _scc_ "Typecheck-Rename"
+ tcRnModule hsc_env pcs_ch rdr_module
+ ; case maybe_tc_result of {
+ Nothing -> return (Left (HscFail pcs_ch));
+ Just tc_result -> do {
+
+ -------------------
+ -- DESUGAR
+ -------------------
+ ; ds_result <- _scc_ "DeSugar"
+ deSugar hsc_env pcs_tc tc_result
+ ; return (Right (pcs_tc, ds_result))
+ }}}}}
+
+
+hscBackEnd 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 dopt_HscLang 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
+
+ other ->
+ do
+ ----------------- Convert to STG ------------------
+ (stg_binds, cost_centre_info) <- _scc_ "CoreToStg"
+ myCoreToStg dflags this_mod prepd_binds
+
+ ------------------ Code generation ------------------
+ abstractC <- _scc_ "CodeGen"
+ codeGen dflags this_mod type_env foreign_stubs
+ dir_imps cost_centre_info stg_binds
+
+ ------------------ Code output -----------------------
+ (stub_h_exists, stub_c_exists)
+ <- codeOutput dflags this_mod foreign_stubs
+ dependencies abstractC
+
+ return (stub_h_exists, stub_c_exists, Nothing)
+ }