X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnMonad.lhs;h=ff1979bc06444f1b0b377bcd8b188fa3ddbbae86;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=616017798c6b1b3b6faad7d47eddb49408387ddd;hpb=853e20a3eb86137cdb8accf69c6caa9db83a3d34;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index 6160177..ff1979b 100644 --- a/ghc/compiler/typecheck/TcRnMonad.lhs +++ b/ghc/compiler/typecheck/TcRnMonad.lhs @@ -10,29 +10,44 @@ module TcRnMonad( import TcRnTypes -- Re-export all import IOEnv -- Re-export all +#if defined(GHCI) && defined(BREAKPOINT) +import TypeRep ( Type(..), liftedTypeKind, TyThing(..) ) +import Var ( mkTyVar, mkGlobalId ) +import IdInfo ( GlobalIdDetails(..), vanillaIdInfo ) +import OccName ( mkOccName, tvName ) +import SrcLoc ( noSrcLoc ) +import TysWiredIn ( intTy, stringTy, mkListTy, unitTy ) +import PrelNames ( breakpointJumpName ) +import NameEnv ( mkNameEnv ) +#endif + import HsSyn ( emptyLHsBinds ) import HscTypes ( HscEnv(..), ModGuts(..), ModIface(..), - TyThing, TypeEnv, emptyTypeEnv, HscSource(..), isHsBoot, + TyThing, TypeEnv, emptyTypeEnv, HscSource(..), + isHsBoot, ModSummary(..), ExternalPackageState(..), HomePackageTable, Deprecs(..), FixityEnv, FixItem, lookupType, unQualInScope ) import Module ( Module, unitModuleEnv ) import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv, LocalRdrEnv, emptyLocalRdrEnv ) -import Name ( Name, isInternalName ) +import Name ( Name, isInternalName, mkInternalName, tidyNameOcc, nameOccName, getSrcLoc ) import Type ( Type ) -import NameEnv ( extendNameEnvList ) +import TcType ( tcIsTyVarTy, tcGetTyVar ) +import NameEnv ( extendNameEnvList, nameEnvElts ) import InstEnv ( emptyInstEnv ) +import Var ( setTyVarName ) import VarSet ( emptyVarSet ) -import VarEnv ( TidyEnv, emptyTidyEnv, emptyVarEnv ) +import VarEnv ( TidyEnv, emptyTidyEnv, extendVarEnv ) import ErrUtils ( Message, Messages, emptyMessages, errorsFound, mkWarnMsg, printErrorsAndWarnings, mkLocMessage, mkLongErrMsg ) +import Packages ( mkHomeModules ) import SrcLoc ( mkGeneralSrcSpan, isGoodSrcSpan, SrcSpan, Located(..) ) import NameEnv ( emptyNameEnv ) import NameSet ( NameSet, emptyDUs, emptyNameSet, unionNameSets, addOneToNameSet ) -import OccName ( emptyOccEnv ) +import OccName ( emptyOccEnv, tidyOccName ) import Bag ( emptyBag ) import Outputable import UniqSupply ( UniqSupply, mkSplitUniqSupply, uniqFromSupply, splitUniqSupply ) @@ -42,7 +57,6 @@ import StaticFlags ( opt_PprStyle_Debug ) import Bag ( snocBag, unionBags ) import Panic ( showException ) -import Maybe ( isJust ) import IO ( stderr ) import DATA_IOREF ( newIORef, readIORef ) import EXCEPTION ( Exception ) @@ -77,7 +91,7 @@ initTc hsc_env hsc_src mod do_this dfuns_var <- newIORef emptyNameSet ; keep_var <- newIORef emptyNameSet ; th_var <- newIORef False ; - + dfun_n_var <- newIORef 1 ; let { gbl_env = TcGblEnv { tcg_mod = mod, @@ -92,12 +106,17 @@ initTc hsc_env hsc_src mod do_this tcg_th_used = th_var, tcg_exports = emptyNameSet, tcg_imports = init_imports, + tcg_home_mods = home_mods, tcg_dus = emptyDUs, + tcg_rn_imports = Nothing, + tcg_rn_exports = Nothing, + tcg_rn_decls = Nothing, tcg_binds = emptyLHsBinds, tcg_deprecs = NoDeprecs, tcg_insts = [], tcg_rules = [], tcg_fords = [], + tcg_dfun_n = dfun_n_var, tcg_keep = keep_var } ; lcl_env = TcLclEnv { @@ -106,20 +125,39 @@ initTc hsc_env hsc_src mod do_this tcl_ctxt = [], tcl_rdr = emptyLocalRdrEnv, tcl_th_ctxt = topStage, - tcl_arrow_ctxt = topArrowCtxt, + tcl_arrow_ctxt = NoArrowCtxt, tcl_env = emptyNameEnv, tcl_tyvars = tvs_var, - tcl_lie = panic "initTc:LIE", -- LIE only valid inside a getLIE - tcl_gadt = emptyVarEnv + tcl_lie = panic "initTc:LIE" -- LIE only valid inside a getLIE } ; } ; -- OK, here's the business end! maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $ - do { r <- tryM do_this - ; case r of - Right res -> return (Just res) - Left _ -> return Nothing } ; + do { +#if defined(GHCI) && defined(BREAKPOINT) + unique <- newUnique ; + let { var = mkInternalName unique (mkOccName tvName "a") noSrcLoc; + tyvar = mkTyVar var liftedTypeKind; + breakpointJumpType = mkGlobalId + (VanillaGlobal) + (breakpointJumpName) + (FunTy intTy + (FunTy (mkListTy unitTy) + (FunTy stringTy + (ForAllTy tyvar + (FunTy (TyVarTy tyvar) + (TyVarTy tyvar)))))) + (vanillaIdInfo); + new_env = mkNameEnv [(breakpointJumpName,AGlobal (AnId breakpointJumpType))]; + }; + r <- tryM (updLclEnv (\gbl -> gbl{tcl_env=new_env}) do_this) +#else + r <- tryM do_this +#endif + ; case r of + Right res -> return (Just res) + Left _ -> return Nothing } ; -- Collect any error messages msgs <- readIORef errs_var ; @@ -131,7 +169,17 @@ initTc hsc_env hsc_src mod do_this return (msgs, final_res) } where - init_imports = emptyImportAvails { imp_env = unitModuleEnv mod emptyNameSet } + home_mods = mkHomeModules (map ms_mod (hsc_mod_graph hsc_env)) + -- A guess at the home modules. This will be correct in + -- --make and GHCi modes, but in one-shot mode we need to + -- fix it up after we know the real dependencies of the current + -- module (see tcRnModule). + -- Setting it here is necessary for the typechecker entry points + -- other than tcRnModule: tcRnGetInfo, for example. These are + -- all called via the GHC module, so hsc_mod_graph will contain + -- something sensible. + + init_imports = emptyImportAvails {imp_env = unitModuleEnv mod emptyNameSet} -- Initialise tcg_imports with an empty set of bindings for -- this module, so that if we see 'module M' in the export -- list, and there are no bindings in M, we don't bleat @@ -144,7 +192,7 @@ initTcPrintErrors -- Used from the interactive loop only -> IO (Maybe r) initTcPrintErrors env mod todo = do (msgs, res) <- initTc env HsSrcFile mod todo - printErrorsAndWarnings msgs + printErrorsAndWarnings (hsc_dflags env) msgs return res -- mkImpTypeEnv makes the imported symbol table @@ -239,8 +287,8 @@ ifOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () -- Do it flag is tru ifOptM flag thing_inside = do { b <- doptM flag; if b then thing_inside else return () } -getGhciMode :: TcRnIf gbl lcl GhcMode -getGhciMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) } +getGhcMode :: TcRnIf gbl lcl GhcMode +getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) } \end{code} \begin{code} @@ -301,6 +349,11 @@ newUniqueSupply let { (us1, us2) = splitUniqSupply us } ; writeMutVar u_var us1 ; return us2 } + +newLocalName :: Name -> TcRnIf gbl lcl Name +newLocalName name -- Make a clone + = newUnique `thenM` \ uniq -> + returnM (mkInternalName uniq (nameOccName name) (getSrcLoc name)) \end{code} @@ -312,31 +365,35 @@ newUniqueSupply \begin{code} traceTc, traceRn :: SDoc -> TcRn () -traceRn = dumpOptTcRn Opt_D_dump_rn_trace -traceTc = dumpOptTcRn Opt_D_dump_tc_trace -traceSplice = dumpOptTcRn Opt_D_dump_splices +traceRn = traceOptTcRn Opt_D_dump_rn_trace +traceTc = traceOptTcRn Opt_D_dump_tc_trace +traceSplice = traceOptTcRn Opt_D_dump_splices traceIf :: SDoc -> TcRnIf m n () -traceIf = dumpOptIf Opt_D_dump_if_trace -traceHiDiffs = dumpOptIf Opt_D_dump_hi_diffs +traceIf = traceOptIf Opt_D_dump_if_trace +traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs -dumpOptIf :: DynFlag -> SDoc -> TcRnIf m n () -- No RdrEnv available, so qualify everything -dumpOptIf flag doc = ifOptM flag $ +traceOptIf :: DynFlag -> SDoc -> TcRnIf m n () -- No RdrEnv available, so qualify everything +traceOptIf flag doc = ifOptM flag $ ioToIOEnv (printForUser stderr alwaysQualify doc) -dumpOptTcRn :: DynFlag -> SDoc -> TcRn () -dumpOptTcRn flag doc = ifOptM flag $ do +traceOptTcRn :: DynFlag -> SDoc -> TcRn () +traceOptTcRn flag doc = ifOptM flag $ do { ctxt <- getErrCtxt ; loc <- getSrcSpanM - ; ctxt_msgs <- do_ctxt emptyTidyEnv ctxt + ; env0 <- tcInitTidyEnv + ; ctxt_msgs <- do_ctxt env0 ctxt ; let real_doc = mkLocMessage loc (vcat (doc : ctxt_to_use ctxt_msgs)) ; dumpTcRn real_doc } dumpTcRn :: SDoc -> TcRn () dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ; ioToTcRn (printForUser stderr (unQualInScope rdr_env) doc) } + +dumpOptTcRn :: DynFlag -> SDoc -> TcRn () +dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc) \end{code} @@ -350,6 +407,9 @@ dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ; getModule :: TcRn Module getModule = do { env <- getGblEnv; return (tcg_mod env) } +setModule :: Module -> TcRn a -> TcRn a +setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside + tcIsHsBoot :: TcRn Bool tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) } @@ -425,7 +485,8 @@ addErrAt loc msg = addLongErrAt loc msg empty addLongErrAt :: SrcSpan -> Message -> Message -> TcRn () addLongErrAt loc msg extra - = do { errs_var <- getErrsVar ; + = do { traceTc (ptext SLIT("Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ; + errs_var <- getErrsVar ; rdr_env <- getGlobalRdrEnv ; let { err = mkLongErrMsg loc (unQualInScope rdr_env) msg extra } ; (warns, errs) <- readMutVar errs_var ; @@ -488,68 +549,88 @@ discardWarnings thing_inside \begin{code} +try_m :: TcRn r -> TcRn (Either Exception r) +-- Does try_m, with a debug-trace on failure +try_m thing + = do { mb_r <- tryM thing ; + case mb_r of + Left exn -> do { traceTc (exn_msg exn); return mb_r } + Right r -> return mb_r } + where + exn_msg exn = text "tryTc/recoverM recovering from" <+> text (showException exn) + +----------------------- recoverM :: TcRn r -- Recovery action; do this if the main one fails -> TcRn r -- Main action: do this first -> TcRn r +-- Errors in 'thing' are retained recoverM recover thing = do { mb_res <- try_m thing ; case mb_res of Left exn -> recover Right res -> returnM res } +----------------------- tryTc :: TcRn a -> TcRn (Messages, Maybe a) - -- (tryTc m) executes m, and returns - -- Just r, if m succeeds (returning r) and caused no errors - -- Nothing, if m fails, or caused errors - -- It also returns all the errors accumulated by m - -- (even in the Just case, there might be warnings) - -- - -- It always succeeds (never raises an exception) +-- (tryTc m) executes m, and returns +-- Just r, if m succeeds (returning r) +-- Nothing, if m fails +-- It also returns all the errors and warnings accumulated by m +-- It always succeeds (never raises an exception) tryTc m = do { errs_var <- newMutVar emptyMessages ; - - mb_r <- try_m (setErrsVar errs_var m) ; - - new_errs <- readMutVar errs_var ; - - dflags <- getDOpts ; - - return (new_errs, - case mb_r of - Left exn -> Nothing - Right r | errorsFound dflags new_errs -> Nothing - | otherwise -> Just r) + res <- try_m (setErrsVar errs_var m) ; + msgs <- readMutVar errs_var ; + return (msgs, case res of + Left exn -> Nothing + Right val -> Just val) + -- The exception is always the IOEnv built-in + -- in exception; see IOEnv.failM } -try_m :: TcRn r -> TcRn (Either Exception r) --- Does try_m, with a debug-trace on failure -try_m thing - = do { mb_r <- tryM thing ; - case mb_r of - Left exn -> do { traceTc (exn_msg exn); return mb_r } - Right r -> return mb_r } - where - exn_msg exn = text "tryTc/recoverM recovering from" <+> text (showException exn) +----------------------- +tryTcErrs :: TcRn a -> TcRn (Messages, Maybe a) +-- Run the thing, returning +-- Just r, if m succceeds with no error messages +-- Nothing, if m fails, or if it succeeds but has error messages +-- Either way, the messages are returned; even in the Just case +-- there might be warnings +tryTcErrs thing + = do { (msgs, res) <- tryTc thing + ; dflags <- getDOpts + ; let errs_found = errorsFound dflags msgs + ; return (msgs, case res of + Nothing -> Nothing + Just val | errs_found -> Nothing + | otherwise -> Just val) + } +----------------------- tryTcLIE :: TcM a -> TcM (Messages, Maybe a) --- Just like tryTc, except that it ensures that the LIE +-- Just like tryTcErrs, except that it ensures that the LIE -- for the thing is propagated only if there are no errors -- Hence it's restricted to the type-check monad tryTcLIE thing_inside - = do { ((errs, mb_r), lie) <- getLIE (tryTc thing_inside) ; - ifM (isJust mb_r) (extendLIEs lie) ; - return (errs, mb_r) } + = do { ((msgs, mb_res), lie) <- getLIE (tryTcErrs thing_inside) ; + ; case mb_res of + Nothing -> return (msgs, Nothing) + Just val -> do { extendLIEs lie; return (msgs, Just val) } + } +----------------------- tryTcLIE_ :: TcM r -> TcM r -> TcM r --- (tryTcLIE_ r m) tries m; if it succeeds it returns it, --- otherwise it returns r. Any error messages added by m are discarded, --- whether or not m succeeds. +-- (tryTcLIE_ r m) tries m; +-- if m succeeds with no error messages, it's the answer +-- otherwise tryTcLIE_ drops everything from m and tries r instead. tryTcLIE_ recover main - = do { (_msgs, mb_res) <- tryTcLIE main ; - case mb_res of - Just res -> return res - Nothing -> recover } + = do { (msgs, mb_res) <- tryTcLIE main + ; case mb_res of + Just val -> do { addMessages msgs -- There might be warnings + ; return val } + Nothing -> recover -- Discard all msgs + } +----------------------- checkNoErrs :: TcM r -> TcM r -- (checkNoErrs m) succeeds iff m succeeds and generates no errors -- If m fails then (checkNoErrsTc m) fails. @@ -558,12 +639,12 @@ checkNoErrs :: TcM r -> TcM r -- If so, it fails too. -- Regardless, any errors generated by m are propagated to the enclosing context. checkNoErrs main - = do { (msgs, mb_res) <- tryTcLIE main ; - addMessages msgs ; - case mb_res of - Just r -> return r - Nothing -> failM - } + = do { (msgs, mb_res) <- tryTcLIE main + ; addMessages msgs + ; case mb_res of + Nothing -> failM + Just val -> return val + } ifErrsM :: TcRn r -> TcRn r -> TcRn r -- ifErrsM bale_out main @@ -598,12 +679,12 @@ getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) } setErrCtxt :: ErrCtxt -> TcM a -> TcM a setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt }) -addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, Message)) -> TcM a -> TcM a -addErrCtxtM msg = updCtxt (\ msgs -> msg : msgs) - addErrCtxt :: Message -> TcM a -> TcM a addErrCtxt msg = addErrCtxtM (\env -> returnM (env, msg)) +addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, Message)) -> TcM a -> TcM a +addErrCtxtM msg = updCtxt (\ msgs -> msg : msgs) + -- Helper function for the above updCtxt :: (ErrCtxt -> ErrCtxt) -> TcM a -> TcM a updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) -> @@ -635,7 +716,8 @@ addInstCtxt (InstLoc _ src_loc ctxt) thing_inside \begin{code} addErrTc :: Message -> TcM () -addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg) +addErrTc err_msg = do { env0 <- tcInitTidyEnv + ; addErrTcM (env0, err_msg) } addErrsTc :: [Message] -> TcM () addErrsTc err_msgs = mappM_ addErrTc err_msgs @@ -669,7 +751,8 @@ checkTc False err = failWithTc err addWarnTc :: Message -> TcM () addWarnTc msg = do { ctxt <- getErrCtxt ; - ctxt_msgs <- do_ctxt emptyTidyEnv ctxt ; + env0 <- tcInitTidyEnv ; + ctxt_msgs <- do_ctxt env0 ctxt ; addWarn (vcat (msg : ctxt_to_use ctxt_msgs)) } warnTc :: Bool -> Message -> TcM () @@ -678,7 +761,32 @@ warnTc warn_if_true warn_msg | otherwise = return () \end{code} - Helper functions +----------------------------------- + Tidying + +We initialise the "tidy-env", used for tidying types before printing, +by building a reverse map from the in-scope type variables to the +OccName that the programmer originally used for them + +\begin{code} +tcInitTidyEnv :: TcM TidyEnv +tcInitTidyEnv + = do { lcl_env <- getLclEnv + ; let nm_tv_prs = [ (name, tcGetTyVar "tcInitTidyEnv" ty) + | ATyVar name ty <- nameEnvElts (tcl_env lcl_env) + , tcIsTyVarTy ty ] + ; return (foldl add emptyTidyEnv nm_tv_prs) } + where + add (env,subst) (name, tyvar) + = case tidyOccName env (nameOccName name) of + (env', occ') -> (env', extendVarEnv subst tyvar tyvar') + where + tyvar' = setTyVarName tyvar name' + name' = tidyNameOcc name occ' +\end{code} + +----------------------------------- + Other helper functions \begin{code} add_err_tcm tidy_env err_msg loc ctxt @@ -696,7 +804,7 @@ ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt | otherwise = take 3 ctxt \end{code} -debugTc is useful for monadi debugging code +debugTc is useful for monadic debugging code \begin{code} debugTc :: TcM () -> TcM () @@ -714,6 +822,13 @@ debugTc thing = return () %************************************************************************ \begin{code} +nextDFunIndex :: TcM Int -- Get the next dfun index +nextDFunIndex = do { env <- getGblEnv + ; let dfun_n_var = tcg_dfun_n env + ; n <- readMutVar dfun_n_var + ; writeMutVar dfun_n_var (n+1) + ; return n } + getLIEVar :: TcM (TcRef LIE) getLIEVar = do { env <- getLclEnv; return (tcl_lie env) } @@ -784,33 +899,6 @@ setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s }) %************************************************************************ %* * - Arrow context -%* * -%************************************************************************ - -\begin{code} -popArrowBinders :: TcM a -> TcM a -- Move to the left of a (-<); see comments in TcRnTypes -popArrowBinders - = updLclEnv (\ env -> env { tcl_arrow_ctxt = pop (tcl_arrow_ctxt env) }) - where - pop (ArrCtxt {proc_level = curr_lvl, proc_banned = banned}) - = ASSERT( not (curr_lvl `elem` banned) ) - ArrCtxt {proc_level = curr_lvl + 1, proc_banned = curr_lvl : banned} - -getBannedProcLevels :: TcM [ProcLevel] -getBannedProcLevels - = do { env <- getLclEnv; return (proc_banned (tcl_arrow_ctxt env)) } - -incProcLevel :: TcM a -> TcM a -incProcLevel - = updLclEnv (\ env -> env { tcl_arrow_ctxt = inc (tcl_arrow_ctxt env) }) - where - inc ctxt = ctxt { proc_level = proc_level ctxt + 1 } -\end{code} - - -%************************************************************************ -%* * Stuff for the renamer's local env %* * %************************************************************************ @@ -864,16 +952,16 @@ initIfaceCheck hsc_env do_this ; initTcRnIf 'i' hsc_env gbl_env () do_this } -initIfaceTc :: HscEnv -> ModIface - -> (TcRef TypeEnv -> IfL a) -> IO a +initIfaceTc :: ModIface + -> (TcRef TypeEnv -> IfL a) -> TcRnIf gbl lcl 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 +initIfaceTc iface do_this + = do { tc_env_var <- newMutVar emptyTypeEnv ; let { gbl_env = IfGblEnv { if_rec_types = Just (mod, readMutVar tc_env_var) } ; ; if_lenv = mkIfLclEnv mod doc } - ; initTcRnIf 'i' hsc_env gbl_env if_lenv (do_this tc_env_var) + ; setEnvs (gbl_env, if_lenv) (do_this tc_env_var) } where mod = mi_module iface @@ -906,7 +994,7 @@ failIfM :: Message -> IfL a -- We use IfL here so that we can get context info out of the local env failIfM msg = do { env <- getLclEnv - ; let full_msg = if_loc env $$ nest 2 msg + ; let full_msg = (if_loc env <> colon) $$ nest 2 msg ; ioToIOEnv (printErrs (full_msg defaultErrStyle)) ; failM } @@ -946,20 +1034,9 @@ 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 + Nothing -> pgmError "Cannot continue after interface file error" + -- pprPanic "forkM" doc Just r -> r) } \end{code} -%************************************************************************ -%* * - Stuff for GADTs -%* * -%************************************************************************ - -\begin{code} -getTypeRefinement :: TcM GadtRefinement -getTypeRefinement = do { lcl_env <- getLclEnv; return (tcl_gadt lcl_env) } -setTypeRefinement :: GadtRefinement -> TcM a -> TcM a -setTypeRefinement gadt = updLclEnv (\env -> env { tcl_gadt = gadt }) -\end{code}