- -- Do saturation and convert to A-normal form
- ; saturated <- coreSatPgm dflags tidy_binds
-
- ; (maybe_stub_h_filename, maybe_stub_c_filename, maybe_bcos)
- <- restOfCodeGeneration dflags toInterp this_mod
- (map ideclName (hsModuleImports rdr_module))
- foreign_stuff env_tc saturated
- 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
+ ; maybe_parsed <- myParseModule (hsc_dflags hsc_env)
+ (expectJust "hscFrontEnd:hspp" (ml_hspp_file location))
+
+ ; case maybe_parsed of {
+ Left err -> do { msg_act (unitBag err, emptyBag) ;
+ ; return (Left HscFail) ;
+ };
+ Right rdr_module -> hscFrontEnd hsc_env msg_act rdr_module
+ }}
+
+-- 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.
+hscBufferFrontEnd :: HscEnv -> StringBuffer -> MessageAction -> IO HscResult
+hscBufferFrontEnd hsc_env buffer msg_act = do
+ let loc = mkSrcLoc (mkFastString "*edit*") 1 0
+ 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
+ r <- hscFrontEnd hsc_env msg_act rdr_module
+ case r of
+ Left r -> return r
+ Right _ -> return HscChecked
+
+
+
+hscFrontEnd hsc_env msg_act rdr_module = do {
+ -------------------
+ -- RENAME and TYPECHECK
+ -------------------
+ ; (tc_msgs, maybe_tc_result) <- _scc_ "Typecheck-Rename"
+ tcRnModule hsc_env rdr_module
+ ; msg_act tc_msgs
+ ; case maybe_tc_result of {
+ Nothing -> return (Left HscFail);
+ 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 (Left HscFail);
+ Just ds_result -> return (Right 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)
+ }
+
+
+hscCmmFile :: DynFlags -> FilePath -> IO Bool
+hscCmmFile dflags filename = do
+ maybe_cmm <- parseCmmFile dflags filename
+ case maybe_cmm of
+ Nothing -> return False
+ Just cmm -> do
+ codeOutput dflags no_mod NoStubs noDependencies [cmm]
+ return True
+ where
+ no_mod = panic "hscCmmFile: no_mod"