- ; (maybe_stub_h_filename, maybe_stub_c_filename, maybe_bcos)
- <- restOfCodeGeneration dflags toInterp this_mod
- (map ideclName (hsModuleImports rdr_module))
- foreign_stuff env_tc tidy_binds
- hit (pcs_PIT pcs_simpl)
-
- -- and the answer is ...
- ; return (HscRecomp pcs_simpl new_details final_iface
- maybe_stub_h_filename maybe_stub_c_filename
- maybe_bcos)
- }}}}}}}
-
-
-
-mkFinalIface ghci_mode 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 when (dopt Opt_D_dump_hi_diffs dflags)
- (printDump (text "INTERFACE UNCHANGED"))
- dumpIfSet_dyn dflags Opt_D_dump_hi
- "UNCHANGED FINAL INTERFACE" (pprIface new_iface)
- return new_iface
- (new_iface, Just sdoc_diffs)
- -> do dumpIfSet_dyn dflags Opt_D_dump_hi_diffs "INTERFACE HAS CHANGED"
- sdoc_diffs
- dumpIfSet_dyn dflags Opt_D_dump_hi "NEW FINAL INTERFACE"
- (pprIface new_iface)
- -- Write the interface file
- when (ghci_mode /= Interactive)
- (writeIface (unJust "hscRecomp:hi" (ml_hi_file location))
- new_iface)
- return new_iface
-
-
-myParseModule dflags src_filename
- = do -------------------------- Parser ----------------
- showPass dflags "Parser"
- _scc_ "Parser" do
-
- buf <- hGetStringBuffer True{-expand tabs-} src_filename
-
- let glaexts | dopt Opt_GlasgowExts dflags = 1#
- | otherwise = 0#
-
- case parseModule buf PState{ bol = 0#, atbol = 1#,
- context = [], glasgow_exts = glaexts,
- loc = mkSrcLoc (_PK_ src_filename) 1 } of {
-
- PFailed err -> do { hPutStrLn stderr (showSDoc err);
- freeStringBuffer buf;
- return Nothing };
-
- POk _ rdr_module@(HsModule mod_name _ _ _ _ _ _) -> do {
+ -- Return the prepared code.
+ ; 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 (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 (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 (HscRecomp hasStub)
+
+hscCodeGenCompile :: CodeGen CgGuts Bool
+hscCodeGenCompile hsc_env mod_summary cgguts
+ = do let CgGuts{ -- This is the last use of the ModGuts in a compilation.
+ -- From now on, we just use the bits we need.
+ cg_module = this_mod,
+ cg_binds = core_binds,
+ cg_tycons = tycons,
+ cg_dir_imps = dir_imps,
+ cg_foreign = foreign_stubs,
+ cg_home_mods = home_mods,
+ cg_dep_pkgs = dependencies } = cgguts
+ dflags = hsc_dflags hsc_env
+ location = ms_location 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
+
+ -------------------
+ -- PREPARE FOR CODE GENERATION
+ -- Do saturation and convert to A-normal form
+ prepd_binds <- {-# SCC "CorePrep" #-}
+ corePrepPgm dflags core_binds data_tycons ;
+ ----------------- Convert to STG ------------------
+ (stg_binds, cost_centre_info)
+ <- {-# SCC "CoreToStg" #-}
+ myCoreToStg dflags home_mods this_mod prepd_binds
+ ------------------ Code generation ------------------
+ abstractC <- {-# SCC "CodeGen" #-}
+ codeGen dflags home_mods this_mod data_tycons
+ foreign_stubs dir_imps cost_centre_info
+ stg_binds
+ ------------------ Code output -----------------------
+ (stub_h_exists,stub_c_exists)
+ <- codeOutput dflags this_mod location foreign_stubs
+ dependencies abstractC
+ return stub_c_exists
+
+hscCodeGenIdentity :: CodeGen a a
+hscCodeGenIdentity hsc_env mod_summary a = return a
+
+hscCodeGenConst :: b -> CodeGen a b
+hscCodeGenConst b hsc_env mod_summary a = return b
+
+hscCodeGenInteractive :: CodeGen (ModIface, ModDetails, CgGuts)
+ (InteractiveStatus, ModIface, ModDetails)
+hscCodeGenInteractive hsc_env mod_summary (iface, details, cgguts)
+#ifdef GHCI
+ = do let CgGuts{ -- This is the last use of the ModGuts in a compilation.
+ -- From now on, we just use the bits we need.
+ cg_module = this_mod,
+ cg_binds = core_binds,
+ cg_tycons = tycons,
+ cg_foreign = foreign_stubs,
+ cg_home_mods = home_mods,
+ cg_dep_pkgs = dependencies } = cgguts
+ dflags = hsc_dflags hsc_env
+ location = ms_location 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
+
+ -------------------
+ -- PREPARE FOR CODE GENERATION
+ -- Do saturation and convert to A-normal form
+ prepd_binds <- {-# SCC "CorePrep" #-}
+ corePrepPgm dflags core_binds data_tycons ;
+ ----------------- Generate byte code ------------------
+ comp_bc <- byteCodeGen dflags prepd_binds data_tycons
+ ------------------ Create f-x-dynamic C-side stuff ---
+ (istub_h_exists, istub_c_exists)
+ <- outputForeignStubs dflags this_mod location foreign_stubs
+ return (InteractiveRecomp istub_c_exists comp_bc, iface, details)
+#else
+ = panic "GHC not compiled with interpreter"
+#endif
+
+
+------------------------------
+
+hscFileCheck :: HscEnv -> ModSummary -> IO (Maybe HscChecked)
+hscFileCheck hsc_env mod_summary = do {
+ -------------------
+ -- PARSE
+ -------------------
+ ; let dflags = hsc_dflags hsc_env
+ 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)
+ True{-save renamed syntax-}
+ rdr_module
+
+ ; printErrorsAndWarnings dflags tc_msgs
+ ; case maybe_tc_result of {
+ Nothing -> return (Just (HscChecked rdr_module Nothing Nothing));
+ Just tc_result -> do
+ let md = ModDetails {
+ md_types = tcg_type_env tc_result,
+ md_exports = tcg_exports tc_result,
+ md_insts = tcg_insts tc_result,
+ md_rules = [panic "no rules"] }
+ -- Rules are CoreRules, not the
+ -- RuleDecls we get out of the typechecker
+ rnInfo = do decl <- tcg_rn_decls tc_result
+ imports <- tcg_rn_imports tc_result
+ let exports = tcg_rn_exports tc_result
+ return (decl,imports,exports)
+ return (Just (HscChecked rdr_module
+ rnInfo
+ (Just (tcg_binds tc_result,
+ tcg_rdr_env tc_result,
+ md))))
+ }}}}
+
+
+hscCmmFile :: DynFlags -> FilePath -> IO Bool
+hscCmmFile dflags filename = do
+ maybe_cmm <- parseCmmFile dflags (mkHomeModules []) filename
+ case maybe_cmm of
+ Nothing -> return False
+ Just cmm -> do
+ codeOutput dflags no_mod no_loc NoStubs [] [cmm]
+ return True
+ where
+ no_mod = panic "hscCmmFile: no_mod"
+ no_loc = ModLocation{ ml_hs_file = Just filename,
+ ml_hi_file = panic "hscCmmFile: no hi file",
+ ml_obj_file = panic "hscCmmFile: no obj file" }
+
+
+myParseModule dflags src_filename maybe_src_buf
+ = -------------------------- Parser ----------------
+ showPass dflags "Parser" >>
+ {-# SCC "Parser" #-} do
+
+ -- sometimes we already have the buffer in memory, perhaps
+ -- because we needed to parse the imports out of it, or get the
+ -- module name.
+ buf <- case maybe_src_buf of
+ Just b -> return b
+ Nothing -> hGetStringBuffer src_filename
+
+ let loc = mkSrcLoc (mkFastString src_filename) 1 0
+
+ case unP parseModule (mkPState buf loc dflags) of {
+
+ PFailed span err -> return (Left (mkPlainErrMsg span err));
+
+ POk _ rdr_module -> do {