From 61663f75b09d05a083bcb2c0c3821528e129fcc2 Mon Sep 17 00:00:00 2001 From: sewardj Date: Wed, 25 Oct 2000 14:42:32 +0000 Subject: [PATCH] [project @ 2000-10-25 14:42:31 by sewardj] Compile up to HscMain. Again :) --- ghc/compiler/coreSyn/CoreTidy.lhs | 2 +- ghc/compiler/deSugar/Desugar.lhs | 1 + ghc/compiler/main/CodeOutput.lhs | 2 +- ghc/compiler/main/DriverPipeline.hs | 5 +- ghc/compiler/main/HscMain.lhs | 105 +++++++++++++++++++++++++---------- ghc/compiler/rename/Rename.lhs | 2 +- ghc/compiler/stgSyn/StgInterp.lhs | 23 +++----- 7 files changed, 91 insertions(+), 49 deletions(-) diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs index 7335d3a..26b1d0e 100644 --- a/ghc/compiler/coreSyn/CoreTidy.lhs +++ b/ghc/compiler/coreSyn/CoreTidy.lhs @@ -76,7 +76,7 @@ tidyCorePgm dflags module_name binds_in orphans_in binds_in1 <- if opt_UsageSPOn then _scc_ "CoreUsageSPInf" - doUsageSPInf dflags us binds_in + doUsageSPInf dflags us binds_in else return binds_in let (tidy_env1, binds_out) = mapAccumL (tidyBind (Just module_name)) diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 70bec84..b658121 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -24,6 +24,7 @@ import DsForeign ( dsForeigns ) import DsExpr () -- Forces DsExpr to be compiled; DsBinds only -- depends on DsExpr.hi-boot. import Module ( Module ) +import Id ( Id ) import VarEnv import VarSet import Bag ( isEmptyBag ) diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs index a8b7d01..3ce6bcd 100644 --- a/ghc/compiler/main/CodeOutput.lhs +++ b/ghc/compiler/main/CodeOutput.lhs @@ -66,7 +66,7 @@ codeOutput dflags mod_name tycons classes core_binds stg_binds do let filenm = dopt_OutName dflags stub_names <- outputForeignStubs dflags c_code h_code case dopt_HscLang dflags of - HscInterpreter -> return stub_names + HscInterpreted -> return stub_names HscAsm -> outputAsm dflags filenm flat_abstractC ncg_uniqs >> return stub_names HscC -> outputC dflags filenm flat_abstractC diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index 981775a..8efa7ee 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverPipeline.hs,v 1.5 2000/10/23 09:03:27 simonpj Exp $ +-- $Id: DriverPipeline.hs,v 1.6 2000/10/25 14:42:32 sewardj Exp $ -- -- GHC Driver -- @@ -731,11 +731,8 @@ data CompResult -- summary and code; Nothing => compilation not reqd -- (old summary and code are still valid) PersistentCompilerState -- updated PCS - (Bag WarnMsg) -- warnings | CompErrs PersistentCompilerState -- updated PCS - (Bag ErrMsg) -- errors - (Bag WarnMsg) -- warnings compile finder summary old_iface hst pcs = do diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index eebf4bd..8808ffc 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -76,22 +76,65 @@ hscMain -> 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 { @@ -119,22 +162,24 @@ hscRecomp dflags core_cmds stg_cmds summary hit hst pcs maybe_old_iface 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 @@ -143,7 +188,7 @@ hscRecomp dflags core_cmds stg_cmds summary hit hst pcs maybe_old_iface (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 @@ -184,10 +229,10 @@ myParseModule dflags summary 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" @@ -199,19 +244,24 @@ restOfCodeGeneration toInterp this_mod imported_modules cost_centre_info -------------------------- 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" @@ -221,8 +271,7 @@ dsThenSimplThenTidy dflags mod tc_result rule_base ds_uniqs (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 diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 30319e4..0b7449a 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -4,7 +4,7 @@ \section[Rename]{Renaming and dependency analysis passes} \begin{code} -module Rename ( renameModule ) where +module Rename ( renameModule, closeIfaceDecls ) where #include "HsVersions.h" diff --git a/ghc/compiler/stgSyn/StgInterp.lhs b/ghc/compiler/stgSyn/StgInterp.lhs index 8ab3c3a..a0d7c1d 100644 --- a/ghc/compiler/stgSyn/StgInterp.lhs +++ b/ghc/compiler/stgSyn/StgInterp.lhs @@ -9,7 +9,7 @@ module StgInterp ( ClosureEnv, ItblEnv, linkIModules, stgToInterpSyn, - runStgI -- tmp, for testing +-- runStgI -- tmp, for testing ) where {- ----------------------------------------------------------------------------- @@ -64,7 +64,7 @@ import Module ( moduleNameFS ) #endif import TyCon ( TyCon, isDataTyCon, tyConDataCons, tyConFamilySize ) -import Class ( Class ) +import Class ( Class, classTyCon ) import InterpSyn import StgSyn import Addr @@ -85,15 +85,10 @@ type ClosureEnv = FiniteMap RdrName HValue -- 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 @@ -128,6 +123,7 @@ runStgI tycons classes stgbinds emptyUFM{-initial de-} ) return result +#endif -- --------------------------------------------------------------------------- -- Convert STG to an unlinked interpretable @@ -140,7 +136,7 @@ stgToInterpSyn :: [StgBinding] 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) @@ -421,7 +417,7 @@ linkIModules :: ClosureEnv -- incoming global closure env; returned updated -> 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 @@ -431,9 +427,9 @@ linkIModules gie gce mods = do 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 @@ -1231,6 +1227,5 @@ load addr = do x <- peek addr foreign import "strncpy" strncpy :: Addr -> ByteArray# -> CInt -> IO () -#endif /* ndef GHCI */ \end{code} -- 1.7.10.4