import ByteCodeInstr
import BreakArray
import NameSet
-import TcRnDriver
import InteractiveEval
+import TcRnDriver
#endif
+import TcIface
+import TcRnMonad ( initIfaceCheck )
import Packages
import NameSet
import RdrName
-- (see msDeps)
let all_home_mods = [ms_mod_name s
| s <- mod_graph, not (isBootSummary s)]
-#ifdef DEBUG
bad_boot_mods = [s | s <- mod_graph, isBootSummary s,
not (ms_mod_name s `elem` all_home_mods)]
-#endif
ASSERT( null bad_boot_mods ) return ()
-- mg2_with_srcimps drops the hi-boot nodes, returning a
HscEnv, -- With an updated HPT
[ModSummary]) -- Mods which succeeded
-upsweep hsc_env old_hpt stable_mods cleanup mods
- = upsweep' hsc_env old_hpt stable_mods cleanup mods 1 (length mods)
+upsweep hsc_env old_hpt stable_mods cleanup sccs = do
+ (res, hsc_env, done) <- upsweep' hsc_env old_hpt [] sccs 1 (length sccs)
+ return (res, hsc_env, reverse done)
where
- upsweep' hsc_env _old_hpt _stable_mods _cleanup
+ upsweep' hsc_env _old_hpt done
[] _ _
- = return (Succeeded, hsc_env, [])
+ = return (Succeeded, hsc_env, done)
- upsweep' hsc_env _old_hpt _stable_mods _cleanup
+ upsweep' hsc_env _old_hpt done
(CyclicSCC ms:_) _ _
= do fatalErrorMsg (hsc_dflags hsc_env) (cyclicModuleErr ms)
- return (Failed, hsc_env, [])
+ return (Failed, hsc_env, done)
- upsweep' hsc_env old_hpt stable_mods cleanup
+ upsweep' hsc_env old_hpt done
(AcyclicSCC mod:mods) mod_index nmods
= do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
-- show (map (moduleUserString.moduleName.mi_module.hm_iface)
case mb_mod_info of
Nothing -> return (Failed, hsc_env, [])
Just mod_info -> do
- { let this_mod = ms_mod_name mod
+ let this_mod = ms_mod_name mod
-- Add new info to hsc_env
- hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info
- hsc_env1 = hsc_env { hsc_HPT = hpt1 }
+ hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info
+ hsc_env1 = hsc_env { hsc_HPT = hpt1 }
-- Space-saving: delete the old HPT entry
-- for mod BUT if mod is a hs-boot
-- node, don't delete it. For the
-- interface, the HPT entry is probaby for the
-- main Haskell source file. Deleting it
- -- would force .. (what?? --SDM)
- old_hpt1 | isBootSummary mod = old_hpt
- | otherwise = delFromUFM old_hpt this_mod
+ -- would force the real module to be recompiled
+ -- every time.
+ old_hpt1 | isBootSummary mod = old_hpt
+ | otherwise = delFromUFM old_hpt this_mod
+
+ done' = mod:done
+
+ -- fixup our HomePackageTable after we've finished compiling
+ -- a mutually-recursive loop. See reTypecheckLoop, below.
+ hsc_env2 <- reTypecheckLoop hsc_env1 mod done'
- ; (restOK, hsc_env2, modOKs)
- <- upsweep' hsc_env1 old_hpt1 stable_mods cleanup
- mods (mod_index+1) nmods
- ; return (restOK, hsc_env2, mod:modOKs)
- }
+ upsweep' hsc_env2 old_hpt1 done' mods (mod_index+1) nmods
-- Compile a single module. Always produce a Linkable for it if
iface = hm_iface hm_info
compile_it :: Maybe Linkable -> IO (Maybe HomeModInfo)
- compile_it = upsweep_compile hsc_env
- summary' mod_index nmods mb_old_iface
+ compile_it = compile hsc_env summary' mod_index nmods mb_old_iface
compile_it_discard_iface
- = upsweep_compile hsc_env
- summary' mod_index nmods Nothing
+ = compile hsc_env summary' mod_index nmods Nothing
in
case target of
compile_it Nothing
--- Run hsc to compile a module
-upsweep_compile :: HscEnv -> ModSummary -> Int -> Int
- -> Maybe ModIface -> Maybe Linkable -> IO (Maybe HomeModInfo)
-upsweep_compile hsc_env summary mod_index nmods mb_old_iface mb_old_linkable
- = do
- compresult <- compile hsc_env summary mb_old_linkable mb_old_iface
- mod_index nmods
-
- case compresult of
- -- Compilation failed. Compile may still have updated the PCS, tho.
- CompErrs -> return Nothing
-
- -- Compilation "succeeded", and may or may not have returned a new
- -- linkable (depending on whether compilation was actually performed
- -- or not).
- CompOK new_details new_iface new_linkable
- -> do let new_info = HomeModInfo { hm_iface = new_iface,
- hm_details = new_details,
- hm_linkable = new_linkable }
- return (Just new_info)
-
-- Filter modules in the HPT
retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
, isJust mb_mod_info ]
-- ---------------------------------------------------------------------------
+-- Typecheck module loops
+
+{-
+See bug #930. This code fixes a long-standing bug in --make. The
+problem is that when compiling the modules *inside* a loop, a data
+type that is only defined at the top of the loop looks opaque; but
+after the loop is done, the structure of the data type becomes
+apparent.
+
+The difficulty is then that two different bits of code have
+different notions of what the data type looks like.
+
+The idea is that after we compile a module which also has an .hs-boot
+file, we re-generate the ModDetails for each of the modules that
+depends on the .hs-boot file, so that everyone points to the proper
+TyCons, Ids etc. defined by the real module, not the boot module.
+Fortunately re-generating a ModDetails from a ModIface is easy: the
+function TcIface.typecheckIface does exactly that.
+
+Picking the modules to re-typecheck is slightly tricky. Starting from
+the module graph consisting of the modules that have already been
+compiled, we reverse the edges (so they point from the imported module
+to the importing module), and depth-first-search from the .hs-boot
+node. This gives us all the modules that depend transitively on the
+.hs-boot module, and those are exactly the modules that we need to
+re-typecheck.
+
+Following this fix, GHC can compile itself with --make -O2.
+-}
+
+reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv
+reTypecheckLoop hsc_env ms graph
+ | not (isBootSummary ms) &&
+ any (\m -> ms_mod m == this_mod && isBootSummary m) graph
+ = do
+ let mss = reachableBackwards (ms_mod_name ms) graph
+ non_boot = filter (not.isBootSummary) mss
+ debugTraceMsg (hsc_dflags hsc_env) 2 $
+ text "Re-typechecking loop: " <> ppr (map ms_mod_name non_boot)
+ typecheckLoop hsc_env (map ms_mod_name non_boot)
+ | otherwise
+ = return hsc_env
+ where
+ this_mod = ms_mod ms
+
+typecheckLoop :: HscEnv -> [ModuleName] -> IO HscEnv
+typecheckLoop hsc_env mods = do
+ new_hpt <-
+ fixIO $ \new_hpt -> do
+ let new_hsc_env = hsc_env{ hsc_HPT = new_hpt }
+ mds <- initIfaceCheck new_hsc_env $
+ mapM (typecheckIface . hm_iface) hmis
+ let new_hpt = addListToUFM old_hpt
+ (zip mods [ hmi{ hm_details = details }
+ | (hmi,details) <- zip hmis mds ])
+ return new_hpt
+ return hsc_env{ hsc_HPT = new_hpt }
+ where
+ old_hpt = hsc_HPT hsc_env
+ hmis = map (expectJust "typecheckLoop" . lookupUFM old_hpt) mods
+
+reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary]
+reachableBackwards mod summaries
+ = [ ms | (ms,_,_) <- map vertex_fn nodes_we_want ]
+ where
+ -- all the nodes reachable by traversing the edges backwards
+ -- from the root node:
+ nodes_we_want = reachable (transposeG graph) root
+
+ -- the rest just sets up the graph:
+ (nodes, lookup_key) = moduleGraphNodes False summaries
+ (graph, vertex_fn, key_fn) = graphFromEdges' nodes
+ root
+ | Just key <- lookup_key HsBootFile mod, Just v <- key_fn key = v
+ | otherwise = panic "reachableBackwards"
+
+-- ---------------------------------------------------------------------------
-- Topological sort of the module graph
topSortModuleGraph
(dflags', hspp_fn, buf)
<- preprocessFile dflags file mb_phase maybe_buf
- (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn
+ (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file
-- Make a ModLocation for this file
location <- mkHomeModLocation dflags mod_name file
-- Preprocess the source file and get its imports
-- The dflags' contains the OPTIONS pragmas
(dflags', hspp_fn, buf) <- preprocessFile dflags src_fn Nothing maybe_buf
- (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn
+ (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn
when (mod_name /= wanted_mod) $
throwDyn $ mkPlainErrMsg mod_loc $
projects / ghc-hetmet.git / blobdiff