+
+%************************************************************************
+%* *
+ Stuff for interface decls
+%* *
+%************************************************************************
+
+\begin{code}
+initIfaceTcRn :: IfG a -> TcRn a
+initIfaceTcRn thing_inside
+ = do { tcg_env <- getGblEnv
+ ; let { if_env = IfGblEnv {
+ if_rec_types = Just (tcg_mod tcg_env, get_type_env),
+ if_is_boot = imp_dep_mods (tcg_imports tcg_env) }
+ ; get_type_env = readMutVar (tcg_type_env_var tcg_env) }
+ ; setEnvs (if_env, ()) thing_inside }
+
+initIfaceExtCore :: IfL a -> TcRn a
+initIfaceExtCore thing_inside
+ = do { tcg_env <- getGblEnv
+ ; let { mod = tcg_mod tcg_env
+ ; if_env = IfGblEnv {
+ if_rec_types = Just (mod, return (tcg_type_env tcg_env)),
+ if_is_boot = imp_dep_mods (tcg_imports tcg_env) }
+ ; if_lenv = IfLclEnv { if_mod = moduleName mod,
+ if_tv_env = emptyOccEnv,
+ if_id_env = emptyOccEnv }
+ }
+ ; setEnvs (if_env, if_lenv) thing_inside }
+
+initIfaceCheck :: HscEnv -> IfG a -> IO a
+-- Used when checking the up-to-date-ness of the old Iface
+-- Initialise the environment with no useful info at all
+initIfaceCheck hsc_env do_this
+ = do { let { gbl_env = IfGblEnv { if_is_boot = emptyModuleEnv,
+ if_rec_types = Nothing } ;
+ }
+ ; initTcRnIf 'i' hsc_env gbl_env () do_this
+ }
+
+initIfaceTc :: HscEnv -> ModIface
+ -> (TcRef TypeEnv -> IfL a) -> IO a
+-- Used when type-checking checking an up-to-date interface file
+-- No type envt from the current module, but we do know the module dependencies
+initIfaceTc hsc_env iface do_this
+ = do { tc_env_var <- newIORef emptyTypeEnv
+ ; let { gbl_env = IfGblEnv { if_is_boot = mkModDeps (dep_mods (mi_deps iface)),
+ if_rec_types = Just (mod, readMutVar tc_env_var) } ;
+ ; if_lenv = IfLclEnv { if_mod = moduleName mod,
+ if_tv_env = emptyOccEnv,
+ if_id_env = emptyOccEnv }
+ }
+ ; initTcRnIf 'i' hsc_env gbl_env if_lenv (do_this tc_env_var)
+ }
+ where
+ mod = mi_module iface
+
+initIfaceRules :: HscEnv -> ModGuts -> IfG a -> IO a
+-- Used when sucking in new Rules in SimplCore
+-- We have available the type envt of the module being compiled, and we must use it
+initIfaceRules hsc_env guts do_this
+ = do { let {
+ is_boot = mkModDeps (dep_mods (mg_deps guts))
+ -- Urgh! But we do somehow need to get the info
+ -- on whether (for this particular compilation) we should
+ -- import a hi-boot file or not.
+ ; type_info = (mg_module guts, return (mg_types guts))
+ ; gbl_env = IfGblEnv { if_is_boot = is_boot,
+ if_rec_types = Just type_info } ;
+ }
+
+ -- Run the thing; any exceptions just bubble out from here
+ ; initTcRnIf 'i' hsc_env gbl_env () do_this
+ }
+
+initIfaceLcl :: ModuleName -> IfL a -> IfM lcl a
+initIfaceLcl mod thing_inside
+ = setLclEnv (IfLclEnv { if_mod = mod,
+ if_tv_env = emptyOccEnv,
+ if_id_env = emptyOccEnv })
+ thing_inside
+
+
+--------------------
+forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)
+-- Run thing_inside in an interleaved thread.
+-- It shares everything with the parent thread, so this is DANGEROUS.
+--
+-- It returns Nothing if the computation fails
+--
+-- It's used for lazily type-checking interface
+-- signatures, which is pretty benign
+
+forkM_maybe doc thing_inside
+ = do { unsafeInterleaveM $
+ do { traceIf (text "Starting fork {" <+> doc)
+ ; mb_res <- tryM thing_inside ;
+ case mb_res of
+ Right r -> do { traceIf (text "} ending fork" <+> doc)
+ ; return (Just r) }
+ Left exn -> do {
+
+ -- Bleat about errors in the forked thread, if -ddump-if-trace is on
+ -- Otherwise we silently discard errors. Errors can legitimately
+ -- happen when compiling interface signatures (see tcInterfaceSigs)
+ ifOptM Opt_D_dump_if_trace
+ (print_errs (hang (text "forkM failed:" <+> doc)
+ 4 (text (show exn))))
+
+ ; traceIf (text "} ending fork (badly)" <+> doc)
+ ; return Nothing }
+ }}
+ where
+ print_errs sdoc = ioToIOEnv (printErrs (sdoc defaultErrStyle))
+
+forkM :: SDoc -> IfL a -> IfL a
+forkM doc thing_inside
+ = do { mb_res <- forkM_maybe doc thing_inside
+ ; return (case mb_res of
+ Nothing -> pprPanic "forkM" doc
+ Just r -> r) }
+\end{code}