X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnMonad.lhs;h=c86b081a2147bc50a213f248b00af27671ac431b;hp=37d4e625a46de15f0e43a2f2957c311131efa0d2;hb=b2524b3960999fffdb3767900f58825903f6560f;hpb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516 diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 37d4e62..c86b081 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -22,6 +22,7 @@ import Name import TcType import InstEnv import FamInstEnv +import PrelNames ( iNTERACTIVE ) import Var import Id @@ -69,12 +70,12 @@ initTc :: HscEnv initTc hsc_env hsc_src keep_rn_syntax mod do_this = do { errs_var <- newIORef (emptyBag, emptyBag) ; + meta_var <- newIORef initTyVarUnique ; tvs_var <- newIORef emptyVarSet ; - dfuns_var <- newIORef emptyNameSet ; - keep_var <- newIORef emptyNameSet ; + keep_var <- newIORef emptyNameSet ; used_rdr_var <- newIORef Set.empty ; th_var <- newIORef False ; - lie_var <- newIORef emptyBag ; + lie_var <- newIORef emptyWC ; dfun_n_var <- newIORef emptyOccSet ; type_env_var <- case hsc_type_env_var hsc_env of { Just (_mod, te_var) -> return te_var ; @@ -88,16 +89,15 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this gbl_env = TcGblEnv { tcg_mod = mod, tcg_src = hsc_src, - tcg_rdr_env = hsc_global_rdr_env hsc_env, + tcg_rdr_env = emptyGlobalRdrEnv, tcg_fix_env = emptyNameEnv, tcg_field_env = RecFields emptyNameEnv emptyNameSet, tcg_default = Nothing, - tcg_type_env = hsc_global_type_env hsc_env, + tcg_type_env = emptyNameEnv, tcg_type_env_var = type_env_var, tcg_inst_env = emptyInstEnv, tcg_fam_inst_env = emptyFamInstEnv, - tcg_inst_uses = dfuns_var, - tcg_th_used = th_var, + tcg_th_used = th_var, tcg_exports = [], tcg_imports = emptyImportAvails, tcg_used_rdrnames = used_rdr_var, @@ -107,19 +107,22 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this tcg_rn_exports = maybe_rn_syntax [], tcg_rn_decls = maybe_rn_syntax emptyRnGroup, - tcg_binds = emptyLHsBinds, - tcg_ev_binds = emptyBag, - tcg_warns = NoWarnings, - tcg_anns = [], - tcg_insts = [], - tcg_fam_insts= [], - tcg_rules = [], - tcg_fords = [], - tcg_dfun_n = dfun_n_var, - tcg_keep = keep_var, - tcg_doc_hdr = Nothing, - tcg_hpc = False, - tcg_main = Nothing + tcg_binds = emptyLHsBinds, + tcg_imp_specs = [], + tcg_sigs = emptyNameSet, + tcg_ev_binds = emptyBag, + tcg_warns = NoWarnings, + tcg_anns = [], + tcg_insts = [], + tcg_fam_insts = [], + tcg_rules = [], + tcg_fords = [], + tcg_vects = [], + tcg_dfun_n = dfun_n_var, + tcg_keep = keep_var, + tcg_doc_hdr = Nothing, + tcg_hpc = False, + tcg_main = Nothing } ; lcl_env = TcLclEnv { tcl_errs = errs_var, @@ -131,7 +134,9 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this tcl_env = emptyNameEnv, tcl_tyvars = tvs_var, tcl_lie = lie_var, - tcl_untch = emptyVarSet + tcl_meta = meta_var, + tcl_untch = initTyVarUnique, + tcl_hetMetLevel = [] } ; } ; @@ -144,7 +149,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this -- Check for unsolved constraints lie <- readIORef lie_var ; - if isEmptyBag lie + if isEmptyWC lie then return () else pprPanic "initTc: unsolved constraints" (pprWantedsWithLocs lie) ; @@ -164,9 +169,8 @@ initTcPrintErrors -- Used from the interactive loop only -> Module -> TcM r -> IO (Messages, Maybe r) -initTcPrintErrors env mod todo = do - (msgs, res) <- initTc env HsSrcFile False mod todo - return (msgs, res) + +initTcPrintErrors env mod todo = initTc env HsSrcFile False mod todo \end{code} %************************************************************************ @@ -239,22 +243,29 @@ Command-line flags getDOpts :: TcRnIf gbl lcl DynFlags getDOpts = do { env <- getTopEnv; return (hsc_dflags env) } -doptM :: DOpt d => d -> TcRnIf gbl lcl Bool +xoptM :: ExtensionFlag -> TcRnIf gbl lcl Bool +xoptM flag = do { dflags <- getDOpts; return (xopt flag dflags) } + +doptM :: DynFlag -> TcRnIf gbl lcl Bool doptM flag = do { dflags <- getDOpts; return (dopt flag dflags) } -- XXX setOptM and unsetOptM operate on different types. One should be renamed. setOptM :: ExtensionFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a setOptM flag = updEnv (\ env@(Env { env_top = top }) -> - env { env_top = top { hsc_dflags = lopt_set_flattened (hsc_dflags top) flag}} ) + env { env_top = top { hsc_dflags = xopt_set (hsc_dflags top) flag}} ) unsetOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a unsetOptM flag = updEnv (\ env@(Env { env_top = top }) -> env { env_top = top { hsc_dflags = dopt_unset (hsc_dflags top) flag}} ) -- | Do it flag is true -ifOptM :: DOpt d => d -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () -ifOptM flag thing_inside = do { b <- doptM flag; +ifDOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () +ifDOptM flag thing_inside = do { b <- doptM flag; + if b then thing_inside else return () } + +ifXOptM :: ExtensionFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () +ifXOptM flag thing_inside = do { b <- xoptM flag; if b then thing_inside else return () } getGhcMode :: TcRnIf gbl lcl GhcMode @@ -306,14 +317,24 @@ getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env) %************************************************************************ \begin{code} +newMetaUnique :: TcM Unique +-- The uniques for TcMetaTyVars are allocated specially +-- in guaranteed linear order, starting at zero for each module +newMetaUnique + = do { env <- getLclEnv + ; let meta_var = tcl_meta env + ; uniq <- readMutVar meta_var + ; writeMutVar meta_var (incrUnique uniq) + ; return uniq } + newUnique :: TcRnIf gbl lcl Unique newUnique = do { env <- getEnv ; - let { u_var = env_us env } ; - us <- readMutVar u_var ; - case splitUniqSupply us of { (us1,_) -> do { - writeMutVar u_var us1 ; - return $! uniqFromSupply us }}} + let { u_var = env_us env } ; + us <- readMutVar u_var ; + case takeUniqFromSupply us of { (uniq, us') -> do { + writeMutVar u_var us' ; + return $! uniq }}} -- NOTE 1: we strictly split the supply, to avoid the possibility of leaving -- a chain of unevaluated supplies behind. -- NOTE 2: we use the uniq in the supply from the MutVar directly, and @@ -324,11 +345,11 @@ newUnique newUniqueSupply :: TcRnIf gbl lcl UniqSupply newUniqueSupply = do { env <- getEnv ; - let { u_var = env_us env } ; - us <- readMutVar u_var ; + let { u_var = env_us env } ; + us <- readMutVar u_var ; case splitUniqSupply us of { (us1,us2) -> do { - writeMutVar u_var us1 ; - return us2 }}} + writeMutVar u_var us1 ; + return us2 }}} newLocalName :: Name -> TcRnIf gbl lcl Name newLocalName name -- Make a clone @@ -386,19 +407,18 @@ traceRn, traceSplice :: SDoc -> TcRn () traceRn = traceOptTcRn Opt_D_dump_rn_trace traceSplice = traceOptTcRn Opt_D_dump_splices - traceIf, traceHiDiffs :: SDoc -> TcRnIf m n () traceIf = traceOptIf Opt_D_dump_if_trace traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs traceOptIf :: DynFlag -> SDoc -> TcRnIf m n () -- No RdrEnv available, so qualify everything -traceOptIf flag doc = ifOptM flag $ +traceOptIf flag doc = ifDOptM flag $ liftIO (printForUser stderr alwaysQualify doc) traceOptTcRn :: DynFlag -> SDoc -> TcRn () -- Output the message, with current location if opt_PprStyle_Debug -traceOptTcRn flag doc = ifOptM flag $ do +traceOptTcRn flag doc = ifDOptM flag $ do { loc <- getSrcSpanM ; let real_doc | opt_PprStyle_Debug = mkLocMessage loc doc @@ -416,7 +436,7 @@ debugDumpTcRn doc | opt_NoDebugOutput = return () | otherwise = dumpTcRn doc dumpOptTcRn :: DynFlag -> SDoc -> TcRn () -dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc) +dumpOptTcRn flag doc = ifDOptM flag (dumpTcRn doc) \end{code} @@ -433,6 +453,9 @@ 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 +getIsGHCi :: TcRn Bool +getIsGHCi = do { mod <- getModule; return (mod == iNTERACTIVE) } + tcIsHsBoot :: TcRn Bool tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) } @@ -590,6 +613,14 @@ addLongErrAt loc msg extra let { err = mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } ; (warns, errs) <- readTcRef errs_var ; writeTcRef errs_var (warns, errs `snocBag` err) } + +dumpDerivingInfo :: SDoc -> TcM () +dumpDerivingInfo doc + = do { dflags <- getDOpts + ; when (dopt Opt_D_dump_deriv dflags) $ do + { rdr_env <- getGlobalRdrEnv + ; let unqual = mkPrintUnqualified dflags rdr_env + ; liftIO (putMsgWith dflags unqual doc) } } \end{code} @@ -669,7 +700,7 @@ tryTcLIE :: TcM a -> TcM (Messages, Maybe a) -- for the thing is propagated only if there are no errors -- Hence it's restricted to the type-check monad tryTcLIE thing_inside - = do { ((msgs, mb_res), lie) <- getConstraints (tryTcErrs thing_inside) ; + = do { ((msgs, mb_res), lie) <- captureConstraints (tryTcErrs thing_inside) ; ; case mb_res of Nothing -> return (msgs, Nothing) Just val -> do { emitConstraints lie; return (msgs, Just val) } @@ -750,11 +781,6 @@ updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) -> env { tcl_ctxt = upd ctxt }) --- Conditionally add an error context -maybeAddErrCtxt :: Maybe Message -> TcM a -> TcM a -maybeAddErrCtxt (Just msg) thing_inside = addErrCtxt msg thing_inside -maybeAddErrCtxt Nothing thing_inside = thing_inside - popErrCtxt :: TcM a -> TcM a popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms }) @@ -866,6 +892,9 @@ add_err_tcm tidy_env err_msg loc ctxt mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc -- Tidy the error info, trimming excessive contexts mkErrInfo env ctxts + | opt_PprStyle_Debug -- In -dppr-debug style the output + = return empty -- just becomes too voluminous + | otherwise = go 0 env ctxts where go :: Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc @@ -935,32 +964,49 @@ setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var }) emitConstraints :: WantedConstraints -> TcM () emitConstraints ct = do { lie_var <- getConstraintVar ; - updTcRef lie_var (`andWanteds` ct) } + updTcRef lie_var (`andWC` ct) } + +emitFlat :: WantedEvVar -> TcM () +emitFlat ct + = do { lie_var <- getConstraintVar ; + updTcRef lie_var (`addFlats` unitBag ct) } + +emitFlats :: Bag WantedEvVar -> TcM () +emitFlats ct + = do { lie_var <- getConstraintVar ; + updTcRef lie_var (`addFlats` ct) } + +emitImplication :: Implication -> TcM () +emitImplication ct + = do { lie_var <- getConstraintVar ; + updTcRef lie_var (`addImplics` unitBag ct) } -emitConstraint :: WantedConstraint -> TcM () -emitConstraint ct +emitImplications :: Bag Implication -> TcM () +emitImplications ct = do { lie_var <- getConstraintVar ; - updTcRef lie_var (`extendWanteds` ct) } + updTcRef lie_var (`addImplics` ct) } -getConstraints :: TcM a -> TcM (a, WantedConstraints) --- (getConstraints m) runs m, and returns the type constraints it generates -getConstraints thing_inside - = do { lie_var <- newTcRef emptyWanteds ; +captureConstraints :: TcM a -> TcM (a, WantedConstraints) +-- (captureConstraints m) runs m, and returns the type constraints it generates +captureConstraints thing_inside + = do { lie_var <- newTcRef emptyWC ; res <- updLclEnv (\ env -> env { tcl_lie = lie_var }) thing_inside ; lie <- readTcRef lie_var ; return (res, lie) } -setUntouchables :: TcTyVarSet -> TcM a -> TcM a -setUntouchables untch_tvs thing_inside - = updLclEnv (\ env -> env { tcl_untch = untch_tvs }) thing_inside - -getUntouchables :: TcM TcTyVarSet -getUntouchables - = do { env <- getLclEnv; return (tcl_untch env) } +captureUntouchables :: TcM a -> TcM (a, Untouchables) +captureUntouchables thing_inside + = do { env <- getLclEnv + ; low_meta <- readTcRef (tcl_meta env) + ; res <- setLclEnv (env { tcl_untch = low_meta }) + thing_inside + ; high_meta <- readTcRef (tcl_meta env) + ; return (res, TouchableRange low_meta high_meta) } isUntouchable :: TcTyVar -> TcM Bool -isUntouchable tv = do { env <- getLclEnv; return (tv `elemVarSet` tcl_untch env) } +isUntouchable tv = do { env <- getLclEnv + ; return (varUnique tv < tcl_untch env) } getLclTypeEnv :: TcM (NameEnv TcTyThing) getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) } @@ -1104,7 +1150,7 @@ failIfM :: Message -> IfL a failIfM msg = do { env <- getLclEnv ; let full_msg = (if_loc env <> colon) $$ nest 2 msg - ; liftIO (printErrs (full_msg defaultErrStyle)) + ; liftIO (printErrs full_msg defaultErrStyle) ; failM } -------------------- @@ -1131,7 +1177,7 @@ forkM_maybe doc thing_inside -- 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 + ifDOptM Opt_D_dump_if_trace (print_errs (hang (text "forkM failed:" <+> doc) 2 (text (show exn)))) @@ -1139,7 +1185,7 @@ forkM_maybe doc thing_inside ; return Nothing } }} where - print_errs sdoc = liftIO (printErrs (sdoc defaultErrStyle)) + print_errs sdoc = liftIO (printErrs sdoc defaultErrStyle) forkM :: SDoc -> IfL a -> IfL a forkM doc thing_inside