-> IO HscResult
hscMain dflags core_cmds stg_cmds summary maybe_old_iface
- output_filename mod_details pcs1
- = do
- source_unchanged :: Bool -- extracted from summary?
+ output_filename mod_details pcs
+ = do {
+ -- ????? source_unchanged :: Bool -- extracted from summary?
+
+ (ch_pcs, check_errs, (recomp_reqd, maybe_checked_iface))
+ <- checkOldIface dflags finder hit hst pcs mod source_unchanged
+ maybe_old_iface;
+ if check_errs then
+ return (HscFail ch_pcs)
+ else do {
- (pcs2, check_errs, (recomp_reqd, maybe_checked_iface))
- <- checkOldIface dflags finder hit hst pcs1 mod source_unchanged
- maybe_old_iface
+ let no_old_iface = not (isJust maybe_checked_iface)
+ what_next | recomp_reqd || no_old_iface = hscRecomp
+ | otherwise = hscNoRecomp
- -- test check_errs and give up if a problem happened
- what_next = if recomp_reqd then hscRecomp else hscNoRecomp
+ return (what_next dflags core_cmds stg_cmds summary hit hst
+ pcs2 maybe_checked_iface)
+ }}
- return $
- what_next dflags core_cmds stg_cmds summary hit hst
- pcs2 maybe_checked_iface
-hscNoRecomp = panic "hscNoRecomp"
+hscNoRecomp dflags core_cmds stg_cmds summary hit hst pcs maybe_old_iface
+ = do {
+ -- we definitely expect to have the old interface available
+ old_iface = case maybe_old_iface of
+ Just old_if -> old_if
+ Nothing -> panic "hscNoRecomp:old_iface"
+
+ -- CLOSURE
+ (pcs_cl, closure_errs, cl_hs_decls)
+ <- closeIfaceDecls dflags finder hit hst pcs old_iface
+ if closure_errs then
+ return (HscFail cl_pcs)
+ else do {
+
+ -- TYPECHECK
+ maybe_tc_result
+ <- typecheckModule dflags mod pcs_cl hst hit pit cl_hs_decls;
+ case maybe_tc_result of {
+ Nothing -> return (HscFail cl_pcs);
+ Just tc_result -> do {
+
+ let pcs_tc = tc_pcs tc_result
+ env_tc = tc_env tc_result
+ binds_tc = tc_binds tc_result
+ local_tycons = tc_tycons tc_result
+ local_classes = tc_classes tc_result
+ local_insts = tc_insts tc_result
+ local_rules = tc_rules tc_result
+
+ -- create a new details from the closed, typechecked, old iface
+ let new_details = mkModDetailsFromIface env_tc local_insts local_rules
+
+ return (HscOK final_details
+ Nothing -- tells CM to use old iface and linkables
+ Nothing Nothing -- foreign export stuff
+ Nothing -- ibinds
+ pcs_tc)
+ }}}}
+
hscRecomp dflags core_cmds stg_cmds summary hit hst pcs maybe_old_iface
= do {
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
+ env_tc = tc_env tc_result
+ binds_tc = tc_binds tc_result
+ local_tycons = tc_tycons tc_result
+ local_classes = tc_classes tc_result
+ local_insts = tc_insts tc_result
-- 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
+ (tidy_binds, orphan_rules, foreign_stuff)
+ <- dsThenSimplThenTidy dflags mod tc_result ds_uniqs
-- CONVERT TO STG
(stg_binds, cost_centre_info, top_level_ids)
<- myCoreToStg c2s_uniqs st_uniqs this_mod tidy_binds
-- cook up a new ModDetails now we (finally) have all the bits
- let new_details = completeModDetails tc_env tidy_binds top_level_ids orphan_rules
+ let new_details = mkModDetails tc_env local_insts tidy_binds
+ top_level_ids orphan_rules
-- and possibly create a new ModIface
let maybe_final_iface = completeIface maybe_old_iface new_iface new_details
(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
+ fe_binders tc_env stg_binds
-- and the answer is ...
return (HscOK new_details maybe_final_iface
restOfCodeGeneration toInterp this_mod imported_modules cost_centre_info
- fe_binders local_tycons local_classes stg_binds
+ foreign_stuff tc_env stg_binds
| toInterp
- = return (Nothing, Nothing, stgToInterpSyn stg_binds local_tycons local_classes)
-
+ = return (Nothing, Nothing,
+ Just (stgToInterpSyn stg_binds local_tycons local_classes))
| otherwise
= do -------------------------- Code generation -------------------------------
show_pass "CodeGen"
-------------------------- Code output -------------------------------
show_pass "CodeOutput"
-- _scc_ "CodeOutput"
+ let (fe_binders, h_code, c_code) = foreign_stuff
(maybe_stub_h_name, maybe_stub_c_name)
<- codeOutput this_mod local_tycons local_classes
occ_anal_tidy_binds stg_binds2
c_code h_code abstractC ncg_uniqs
- return (maybe_stub_h_name, maybe_stub_c_name, [{-UnlinkedIBind-}])
+ return (maybe_stub_h_name, maybe_stub_c_name, Nothing)
+ where
+ local_tycons = tcEnvTyCons tc_env
+ local_classes = tcEnvClasses tc_env
-dsThenSimplThenTidy dflags mod tc_result rule_base ds_uniqs
+dsThenSimplThenTidy dflags mod tc_result
+-- make up ds_uniqs here
= do -------------------------- Desugaring ----------------
-- _scc_ "DeSugar"
(desugared, rules, h_code, c_code, fe_binders)
- <- deSugar this_mod ds_uniqs tc_results
+ <- deSugar this_mod ds_uniqs tc_result
-------------------------- Main Core-language transformations ----------------
-- _scc_ "Core2Core"
(tidy_binds, tidy_orphan_rules)
<- tidyCorePgm this_mod simplified orphan_rules
- return (tidy_binds, tidy_orphan_rules, fe_binders, h_code, c_code)
-
+ return (tidy_binds, tidy_orphan_rules, (fe_binders,h_code,c_code))
myCoreToStg c2s_uniqs st_uniqs this_mod tidy_binds
ClosureEnv, ItblEnv,
linkIModules,
stgToInterpSyn,
- runStgI -- tmp, for testing
+-- runStgI -- tmp, for testing
) where
{- -----------------------------------------------------------------------------
#endif
import TyCon ( TyCon, isDataTyCon, tyConDataCons, tyConFamilySize )
-import Class ( Class )
+import Class ( Class, classTyCon )
import InterpSyn
import StgSyn
import Addr
-- Run our STG program through the interpreter
-- ---------------------------------------------------------------------------
+#if 0
+-- To be nuked at some point soon.
runStgI :: [TyCon] -> [Class] -> [StgBinding] -> IO Int
-#ifndef GHCI
-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
emptyUFM{-initial de-}
)
return result
+#endif
-- ---------------------------------------------------------------------------
-- Convert STG to an unlinked interpretable
stgToInterpSyn binds local_tycons local_classes
= do let ibinds = concatMap (translateBind emptyUniqSet) binds
let tycs = local_tycons ++ map classTyCon local_classes
- itblenv <- makeItbls tycs
+ itblenv <- mkITbls tycs
return (ibinds, itblenv)
-> ItblEnv -- incoming global itbl env; returned updated
-> [([UnlinkedIBind], ItblEnv)]
-> IO ([LinkedIBind], ItblEnv, ClosureEnv)
-linkIModules gie gce mods = do
+linkIModules gce gie mods = do
let (bindss, ies) = unzip mods
binds = concat bindss
top_level_binders = map (toRdrName.binder) binds
new_gce = addListToFM gce (zip top_level_binders new_rhss)
new_rhss = map (\b -> evalP (bindee b) emptyUFM) new_binds
---vvvvvvvvv---------------------------------------^^^^^^^^^-- circular
- (new_binds, final_gce) = linkIBinds final_gie new_gce binds
+ new_binds = linkIBinds final_gie new_gce binds
- return (new_binds, final_gie, final_gce)
+ return (new_binds, final_gie, new_gce)
-- We're supposed to augment the environments with the values of any
foreign import "strncpy" strncpy :: Addr -> ByteArray# -> CInt -> IO ()
-#endif /* ndef GHCI */
\end{code}
projects / ghc-hetmet.git / commitdiff