diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs
index 348831a1553dc02ada03a6b3f2eb4aef5e25e6d9..f9a7373e1558adcd355e9a35c084992d61fe7ad0 100644
--- a/ghc/compiler/main/CmdLineOpts.lhs
+++ b/ghc/compiler/main/CmdLineOpts.lhs
@@ -300,7 +300,8 @@ data HscLang
= HscC
| HscAsm
| HscJava
- | HscInterpreter
+ | HscInterpreted
+ deriving Eq
dopt_HscLang :: DynFlags -> HscLang
dopt_HscLang = hscLang
diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs
index 1f5931530d2207da6945ed4a8d47155a4fa8f52e..0be91c56070aacc96ed5df8b4db6a8889e8df37e 100644
--- a/ghc/compiler/main/HscMain.lhs
+++ b/ghc/compiler/main/HscMain.lhs
@@ -61,11 +61,10 @@ data HscResult
(Maybe String) -- generated stub_c filename (in /tmp)
(Maybe [UnlinkedIBind]) -- interpreted code, if any
PersistentCompilerState -- updated PCS
- (Bag WarnMsg) -- warnings
- | HscErrs PersistentCompilerState -- updated PCS
- (Bag ErrMsg) -- errors
- (Bag WarnMsg) -- warnings
+ | HscFail PersistentCompilerState -- updated PCS
+ -- no errors or warnings; the individual passes
+ -- (parse/rename/typecheck) print messages themselves
hscMain
:: DynFlags
@@ -95,35 +94,42 @@ hscMain dflags core_cmds stg_cmds summary maybe_old_iface
hscNoRecomp = panic "hscNoRecomp"
hscRecomp dflags core_cmds stg_cmds summary hit hst pcs maybe_old_iface
- = do
- -- parsed :: RdrNameHsModule
- parsed <- parseModule summary
- -- check for parse errors
+ = do {
+ -- what target are we shooting for?
+ let toInterp = dopt_HscLang dflags == HscInterpreted;
- (pcs_rn, maybe_rn_result)
- <- renameModule dflags finder hit hst pcs mod parsed
-
- -- check maybe_rn_result for failure
+ -- PARSE
+ maybe_parsed <- myParseModule dflags summary;
+ case maybe_parsed of {
+ Nothing -> return (HscFail pcs);
+ Just rdr_module -> do {
- (new_iface, rn_hs_decls) = unJust maybe_rn_result
+ -- RENAME
+ (pcs_rn, maybe_rn_result)
+ <- renameModule dflags finder hit hst pcs mod rdr_module;
+ case maybe_rn_result of {
+ Nothing -> return (HscFail pcs_rn);
+ Just (new_iface, rn_hs_decls) -> do {
+ -- TYPECHECK
maybe_tc_result
- <- typecheckModule dflags mod pcs hst hit pit rn_hs_decls
-
- -- check maybe_tc_result for failure
- let tc_result = unJust maybe_tc_result
- let tc_pcs = tc_pcs tc_result
- let tc_env = tc_env tc_result
- let tc_binds = tc_binds tc_result
- let local_tycons = tc_tycons tc_result
+ <- typecheckModule dflags mod pcs_rn hst hit pit rn_hs_decls;
+ case maybe_tc_result of {
+ Nothing -> return (HscFail pcs_rn);
+ Just tc_result -> do {
+
+ let pcs_tc = tc_pcs tc_result
+ let env_tc = tc_env tc_result
+ let binds_tc = tc_binds tc_result
+ let local_tycons = tc_tycons tc_result
let local_classes = tc_classes tc_result
- -- desugar, simplify and tidy, to create the unfoldings
- -- why is this IO-typed?
+ -- DESUGAR, SIMPLIFY, TIDY-CORE
+ -- We grab the the unfoldings at this point.
(tidy_binds, orphan_rules, fe_binders, h_code, c_code) -- return modDetails?
<- dsThenSimplThenTidy dflags mod tc_result rule_base ds_uniqs
- -- convert to Stg; needed for binders
+ -- CONVERT TO STG
(stg_binds, cost_centre_info, top_level_ids)
<- myCoreToStg c2s_uniqs st_uniqs this_mod tidy_binds
@@ -134,18 +140,54 @@ hscRecomp dflags core_cmds stg_cmds summary hit hst pcs maybe_old_iface
let maybe_final_iface = completeIface maybe_old_iface new_iface new_details
-- do the rest of code generation/emission
- -- this is obviously nonsensical: FIX
- (unlinkeds, stub_h_filename, stub_c_filename)
- <- restOfCodeGeneration this_mod imported_modules cost_centre_info
+ (maybe_ibinds, maybe_stub_h_filename, maybe_stub_c_filename)
+ <- restOfCodeGeneration toInterp
+ this_mod imported_modules cost_centre_info
fe_binders local_tycons local_classes stg_binds
-- and the answer is ...
- return (HscOK new_details maybe_final_iface stub_h_filename stub_c_filename
- unlinkeds tc_pcs (unionBags rn_warns tc_warns))
+ return (HscOK new_details maybe_final_iface
+ maybe_stub_h_filename maybe_stub_c_filename
+ maybe_ibinds pcs_tc)
+ }}}}}}}
+
+myParseModule dflags summary
+ = do -------------------------- Reader ----------------
+ show_pass "Parser"
+ -- _scc_ "Parser"
+
+ let src_filename -- name of the preprocessed source file
+ = case ms_ppsource summary of
+ Just (filename, fingerprint) -> filename
+ Nothing -> pprPanic "myParseModule:summary is not of a source module"
+ (ppr summary)
+
+ buf <- hGetStringBuffer True{-expand tabs-} src_filename
+
+ let glaexts | dopt Opt_GlasgowExts dflags = 1#
+ | otherwise = 0#
+ case parse buf PState{ bol = 0#, atbol = 1#,
+ context = [], glasgow_exts = glaexts,
+ loc = mkSrcLoc src_filename 1 } of {
-restOfCodeGeneration this_mod imported_modules cost_centre_info
+ PFailed err -> do hPutStrLn stderr (showSDoc err)
+ return Nothing
+ POk _ rdr_module@(HsModule mod_name _ _ _ _ _ _) ->
+
+ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module)
+ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"
+ (ppSourceStats False rdr_module)
+
+ return (Just rdr_module)
+
+
+restOfCodeGeneration toInterp this_mod imported_modules cost_centre_info
fe_binders local_tycons local_classes stg_binds
+ | toInterp
+ = return (Nothing, Nothing, stgToIBinds stg_binds local_tycons local_classes)
+
+ | otherwise
= do -------------------------- Code generation -------------------------------
show_pass "CodeGen"
-- _scc_ "CodeGen"
@@ -161,8 +203,7 @@ restOfCodeGeneration this_mod imported_modules cost_centre_info
occ_anal_tidy_binds stg_binds2
c_code h_code abstractC ncg_uniqs
- -- this is obviously nonsensical: FIX
- return (maybe_stub_h_name, maybe_stub_c_name, [])
+ return (maybe_stub_h_name, maybe_stub_c_name, [{-UnlinkedIBind-}])
dsThenSimplThenTidy dflags mod tc_result rule_base ds_uniqs
diff --git a/ghc/compiler/stgSyn/StgInterp.lhs b/ghc/compiler/stgSyn/StgInterp.lhs
index 7c0eb6e701865a216eeec3f22698b71ec355ac19..fecb54bc4c44b432ff5d49c9c28ccc7666ebb0d5 100644
--- a/ghc/compiler/stgSyn/StgInterp.lhs
+++ b/ghc/compiler/stgSyn/StgInterp.lhs
@@ -11,6 +11,8 @@ module StgInterp (
linkIModules, -- :: ItblEnv -> ClosureEnv -> [[UnlinkedIBind]] ->
-- ([LinkedIBind], ItblEnv, ClosureEnv)
+ stgToIBinds, -- :: [StgBinding] -> [UnlinkedIBind]
+
runStgI -- tmp, for testing
) where
@@ -94,11 +96,13 @@ runStgI = panic "StgInterp.runStgI: not implemented"
linkIModules = panic "StgInterp.linkIModules: not implemented"
#else
+
+
-- the bindings need to have a binding for stgMain, and the
-- body of it had better represent something of type Int# -> Int#
runStgI tycons classes stgbinds
= do
- let unlinked_binds = concatMap (stg2IBinds emptyUniqSet) stgbinds
+ let unlinked_binds = concatMap (translateBind emptyUniqSet) stgbinds
{-
let dbg_txt
@@ -133,9 +137,13 @@ runStgI tycons classes stgbinds
-- Convert STG to an unlinked interpretable
-- ---------------------------------------------------------------------------
-stg2IBinds :: UniqSet Id -> StgBinding -> [UnlinkedIBind]
-stg2IBinds ie (StgNonRec v e) = [IBind v (rhs2expr ie e)]
-stg2IBinds ie (StgRec vs_n_es) = [IBind v (rhs2expr ie' e) | (v,e) <- vs_n_es]
+-- visible from outside
+stgToIBinds :: [StgBinding] -> [UnlinkedIBind]
+stgToIBinds = concatMap (translateBind emptyUniqSet)
+
+translateBind :: UniqSet Id -> StgBinding -> [UnlinkedIBind]
+translateBind ie (StgNonRec v e) = [IBind v (rhs2expr ie e)]
+translateBind ie (StgRec vs_n_es) = [IBind v (rhs2expr ie' e) | (v,e) <- vs_n_es]
where ie' = addListToUniqSet ie (map fst vs_n_es)
isRec (StgNonRec _ _) = False
@@ -336,12 +344,12 @@ stg2expr ie stgexpr
StgLet binds@(StgNonRec v e) body
-> mkNonRec (repOfStgExpr stgexpr)
- (head (stg2IBinds ie binds))
+ (head (translateBind ie binds))
(stg2expr (addOneToUniqSet ie v) body)
StgLet binds@(StgRec bs) body
-> mkRec (repOfStgExpr stgexpr)
- (stg2IBinds ie binds)
+ (translateBind ie binds)
(stg2expr (addListToUniqSet ie (map fst bs)) body)
other
@@ -416,7 +424,7 @@ linkIModules ie ce mods = do
new_ie <- mkITbls (concat tyconss)
let new_ce = addListToFM ce (zip top_level_binders new_rhss)
new_rhss = map (\b -> evalP (bindee b) emptyUFM) new_binds
- ---vvvvvvvvv--------------------------------------^^^^^^^^^-- circular
+ ---vvvvvvvvv---------------------------------------^^^^^^^^^-- circular
(new_binds, final_ie, final_ce) = linkIBinds new_ie new_ce binds
return (new_binds, final_ie, final_ce)