Commit 49db9fd3 authored by sewardj's avatar sewardj
Browse files

[project @ 2000-10-25 10:23:57 by sewardj]

HscMain: more details on parsing and codegen, and handle parse/rename/tc
failure correctly.
parent 4102e5ce
......@@ -300,7 +300,8 @@ data HscLang
= HscC
| HscAsm
| HscJava
| HscInterpreter
| HscInterpreted
deriving Eq
dopt_HscLang :: DynFlags -> HscLang
dopt_HscLang = hscLang
......
......@@ -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
......
......@@ -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)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment