diff options
Diffstat (limited to 'compiler/GHC/Tc/Utils')
| -rw-r--r-- | compiler/GHC/Tc/Utils/Instantiate.hs | 64 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Utils/Monad.hs | 70 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Utils/Zonk.hs | 85 |
3 files changed, 135 insertions, 84 deletions
diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs index 80f3a477dd..84e28a75e8 100644 --- a/compiler/GHC/Tc/Utils/Instantiate.hs +++ b/compiler/GHC/Tc/Utils/Instantiate.hs @@ -12,7 +12,8 @@ module GHC.Tc.Utils.Instantiate ( topSkolemise, - topInstantiate, instantiateSigma, + topInstantiate, + instantiateSigma, instCall, instDFunType, instStupidTheta, instTyVarsWith, newWanted, newWanteds, @@ -189,25 +190,25 @@ topSkolemise ty = return (wrap, tv_prs, ev_vars, substTy subst ty) -- substTy is a quick no-op on an empty substitution --- | Instantiate all outer type variables --- and any context. Never looks through arrows. -topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType) --- if topInstantiate ty = (wrap, rho) --- and e :: ty --- then wrap e :: rho (that is, wrap :: ty "->" rho) --- NB: always returns a rho-type, with no top-level forall or (=>) -topInstantiate orig ty - | (tvs, theta, body) <- tcSplitSigmaTy ty +topInstantiate ::CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType) +-- Instantiate outer invisible binders (both Inferred and Specified) +-- If top_instantiate ty = (wrap, inner_ty) +-- then wrap :: inner_ty "->" ty +-- NB: returns a type with no (=>), +-- and no invisible forall at the top +topInstantiate orig sigma + | (tvs, body1) <- tcSplitSomeForAllTyVars isInvisibleArgFlag sigma + , (theta, body2) <- tcSplitPhiTy body1 , not (null tvs && null theta) - = do { (_, wrap1, body1) <- instantiateSigma orig tvs theta body + = do { (_, wrap1, body3) <- instantiateSigma orig tvs theta body2 -- Loop, to account for types like -- forall a. Num a => forall b. Ord b => ... - ; (wrap2, rho) <- topInstantiate orig body1 + ; (wrap2, body4) <- topInstantiate orig body3 - ; return (wrap2 <.> wrap1, rho) } + ; return (wrap2 <.> wrap1, body4) } - | otherwise = return (idHsWrapper, ty) + | otherwise = return (idHsWrapper, sigma) instantiateSigma :: CtOrigin -> [TyVar] -> TcThetaType -> TcSigmaType -> TcM ([TcTyVar], HsWrapper, TcSigmaType) @@ -658,34 +659,18 @@ cases (the rest are caught in lookupInst). newOverloadedLit :: HsOverLit GhcRn -> ExpRhoType -> TcM (HsOverLit GhcTc) -newOverloadedLit - lit@(OverLit { ol_val = val, ol_ext = rebindable }) res_ty - | not rebindable - = do { res_ty <- expTypeToType res_ty - ; dflags <- getDynFlags - ; let platform = targetPlatform dflags - ; case shortCutLit platform val res_ty of - -- Do not generate a LitInst for rebindable syntax. - -- Reason: If we do, tcSimplify will call lookupInst, which - -- will call tcSyntaxName, which does unification, - -- which tcSimplify doesn't like - Just expr -> return (lit { ol_witness = expr - , ol_ext = OverLitTc False res_ty }) - Nothing -> newNonTrivialOverloadedLit orig lit - (mkCheckExpType res_ty) } - - | otherwise - = newNonTrivialOverloadedLit orig lit res_ty - where - orig = LiteralOrigin lit +newOverloadedLit lit res_ty + = do { mb_lit' <- tcShortCutLit lit res_ty + ; case mb_lit' of + Just lit' -> return lit' + Nothing -> newNonTrivialOverloadedLit lit res_ty } -- Does not handle things that 'shortCutLit' can handle. See also -- newOverloadedLit in GHC.Tc.Utils.Unify -newNonTrivialOverloadedLit :: CtOrigin - -> HsOverLit GhcRn +newNonTrivialOverloadedLit :: HsOverLit GhcRn -> ExpRhoType -> TcM (HsOverLit GhcTc) -newNonTrivialOverloadedLit orig +newNonTrivialOverloadedLit lit@(OverLit { ol_val = val, ol_witness = HsVar _ (L _ meth_name) , ol_ext = rebindable }) res_ty = do { hs_lit <- mkOverLit val @@ -697,7 +682,10 @@ newNonTrivialOverloadedLit orig ; res_ty <- readExpType res_ty ; return (lit { ol_witness = witness , ol_ext = OverLitTc rebindable res_ty }) } -newNonTrivialOverloadedLit _ lit _ + where + orig = LiteralOrigin lit + +newNonTrivialOverloadedLit lit _ = pprPanic "newNonTrivialOverloadedLit" (ppr lit) ------------ diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index 0c276d9e16..493602fea0 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -896,19 +896,23 @@ getSrcSpanM :: TcRn SrcSpan -- Avoid clash with Name.getSrcLoc getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env) Nothing) } --- See Note [Rebindable syntax and HsExpansion]. +-- See Note [Error contexts in generated code] inGeneratedCode :: TcRn Bool inGeneratedCode = tcl_in_gen_code <$> getLclEnv setSrcSpan :: SrcSpan -> TcRn a -> TcRn a -setSrcSpan (RealSrcSpan loc _) thing_inside = - updLclEnv (\env -> env { tcl_loc = loc, tcl_in_gen_code = False }) - thing_inside +-- See Note [Error contexts in generated code] +-- for the tcl_in_gen_code manipulation +setSrcSpan (RealSrcSpan loc _) thing_inside + = updLclEnv (\env -> env { tcl_loc = loc, tcl_in_gen_code = False }) + thing_inside + setSrcSpan loc@(UnhelpfulSpan _) thing_inside - -- See Note [Rebindable syntax and HsExpansion]. - | isGeneratedSrcSpan loc = - updLclEnv (\env -> env { tcl_in_gen_code = True }) thing_inside - | otherwise = thing_inside + | isGeneratedSrcSpan loc + = updLclEnv (\env -> env { tcl_in_gen_code = True }) thing_inside + + | otherwise + = thing_inside addLocM :: (a -> TcM b) -> Located a -> TcM b addLocM fn (L loc a) = setSrcSpan loc $ fn a @@ -1101,7 +1105,20 @@ is applied to four arguments. See #18379 for a concrete example. This reliance on delicate inlining and Called Arity is not good. See #18202 for a more general approach. But meanwhile, these ininings seem unobjectional, and they solve the immediate -problem. -} +problem. + +Note [Error contexts in generated code] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* setSrcSpan sets tc_in_gen_code to True if the SrcSpan is GeneratedSrcSpan, + and back to False when we get a useful SrcSpan + +* When tc_in_gen_code is True, addErrCtxt becomes a no-op. + +So typically it's better to do setSrcSpan /before/ addErrCtxt. + +See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr for +more discussion of this fancy footwork. +-} getErrCtxt :: TcM [ErrCtxt] getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) } @@ -1119,7 +1136,7 @@ addErrCtxt msg = addErrCtxtM (\env -> return (env, msg)) -- | Add a message to the error context. This message may do tidying. addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a {-# INLINE addErrCtxtM #-} -- Note [Inlining addErrCtxt] -addErrCtxtM ctxt m = updCtxt (push_ctxt (False, ctxt)) m +addErrCtxtM ctxt = pushCtxt (False, ctxt) -- | Add a fixed landmark message to the error context. A landmark -- message is always sure to be reported, even if there is a lot of @@ -1133,24 +1150,25 @@ addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg)) -- and tidying. addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a {-# INLINE addLandmarkErrCtxtM #-} -- Note [Inlining addErrCtxt] -addLandmarkErrCtxtM ctxt m = updCtxt (push_ctxt (True, ctxt)) m - -push_ctxt :: (Bool, TidyEnv -> TcM (TidyEnv, SDoc)) - -> Bool -> [ErrCtxt] -> [ErrCtxt] -push_ctxt ctxt in_gen ctxts - | in_gen = ctxts - | otherwise = ctxt : ctxts - -updCtxt :: (Bool -> [ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a -{-# INLINE updCtxt #-} -- Note [Inlining addErrCtxt] --- Helper function for the above --- The Bool is true if we are in generated code -updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt - , tcl_in_gen_code = in_gen }) -> - env { tcl_ctxt = upd in_gen ctxt }) +addLandmarkErrCtxtM ctxt = pushCtxt (True, ctxt) + +pushCtxt :: ErrCtxt -> TcM a -> TcM a +{-# INLINE pushCtxt #-} -- Note [Inlining addErrCtxt] +pushCtxt ctxt = updLclEnv (updCtxt ctxt) + +updCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv +-- Do not update the context if we are in generated code +-- See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr +updCtxt ctxt env@(TcLclEnv { tcl_ctxt = ctxts, tcl_in_gen_code = in_gen }) + | in_gen = env + | otherwise = env { tcl_ctxt = ctxt : ctxts } popErrCtxt :: TcM a -> TcM a -popErrCtxt = updCtxt (\ _ msgs -> case msgs of { [] -> []; (_ : ms) -> ms }) +popErrCtxt = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) -> + env { tcl_ctxt = pop ctxt }) + where + pop [] = [] + pop (_:msgs) = msgs getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc getCtLocM origin t_or_k diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs index 4fb5286c70..aad5299bbf 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -20,7 +20,7 @@ module GHC.Tc.Utils.Zonk ( -- * Other HsSyn functions mkHsDictLet, mkHsApp, mkHsAppTy, mkHsCaseAlt, - shortCutLit, hsOverLitName, + tcShortCutLit, shortCutLit, hsOverLitName, conLikeResTy, -- * re-exported from TcMonad @@ -90,6 +90,7 @@ import GHC.Types.Basic import GHC.Types.SrcLoc import GHC.Types.Unique.FM import GHC.Types.TyThing +import GHC.Driver.Session( getDynFlags, targetPlatform ) import GHC.Data.Maybe import GHC.Data.Bag @@ -151,28 +152,75 @@ hsLitType (HsRat _ _ ty) = ty hsLitType (HsFloatPrim _ _) = floatPrimTy hsLitType (HsDoublePrim _ _) = doublePrimTy +{- ********************************************************************* +* * + Short-cuts for overloaded numeric literals +* * +********************************************************************* -} + -- Overloaded literals. Here mainly because it uses isIntTy etc +{- Note [Short cut for overloaded literals] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A literal like "3" means (fromInteger @ty (dNum :: Num ty) (3::Integer)). +But if we have a list like + [4,2,3,2,4,4,2]::[Int] +we use a lot of compile time and space generating and solving all those Num +constraints, and generating calls to fromInteger etc. Better just to cut to +the chase, and cough up an Int literal. Large collections of literals like this +sometimes appear in source files, so it's quite a worthwhile fix. + +So we try to take advantage of whatever nearby type information we have, +to short-cut the process for built-in types. We can do this in two places; + +* In the typechecker, when we are about to typecheck the literal. +* If that fails, in the desugarer, once we know the final type. +-} + +tcShortCutLit :: HsOverLit GhcRn -> ExpRhoType -> TcM (Maybe (HsOverLit GhcTc)) +tcShortCutLit lit@(OverLit { ol_val = val, ol_ext = rebindable }) exp_res_ty + | not rebindable + , Just res_ty <- checkingExpType_maybe exp_res_ty + = do { dflags <- getDynFlags + ; let platform = targetPlatform dflags + ; case shortCutLit platform val res_ty of + Just expr -> return $ Just $ + lit { ol_witness = expr + , ol_ext = OverLitTc False res_ty } + Nothing -> return Nothing } + | otherwise + = return Nothing + shortCutLit :: Platform -> OverLitVal -> TcType -> Maybe (HsExpr GhcTc) -shortCutLit platform (HsIntegral int@(IL src neg i)) ty - | isIntTy ty && platformInIntRange platform i = Just (HsLit noExtField (HsInt noExtField int)) - | isWordTy ty && platformInWordRange platform i = Just (mkLit wordDataCon (HsWordPrim src i)) - | isIntegerTy ty = Just (HsLit noExtField (HsInteger src i ty)) - | otherwise = shortCutLit platform (HsFractional (integralFractionalLit neg i)) ty +shortCutLit platform val res_ty + = case val of + HsIntegral int_lit -> go_integral int_lit + HsFractional frac_lit -> go_fractional frac_lit + HsIsString s src -> go_string s src + where + go_integral int@(IL src neg i) + | isIntTy res_ty && platformInIntRange platform i + = Just (HsLit noExtField (HsInt noExtField int)) + | isWordTy res_ty && platformInWordRange platform i + = Just (mkLit wordDataCon (HsWordPrim src i)) + | isIntegerTy res_ty + = Just (HsLit noExtField (HsInteger src i res_ty)) + | otherwise + = go_fractional (integralFractionalLit neg i) -- The 'otherwise' case is important -- Consider (3 :: Float). Syntactically it looks like an IntLit, -- so we'll call shortCutIntLit, but of course it's a float -- This can make a big difference for programs with a lot of -- literals, compiled without -O -shortCutLit _ (HsFractional f) ty - | isFloatTy ty = Just (mkLit floatDataCon (HsFloatPrim noExtField f)) - | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim noExtField f)) - | otherwise = Nothing + go_fractional f + | isFloatTy res_ty = Just (mkLit floatDataCon (HsFloatPrim noExtField f)) + | isDoubleTy res_ty = Just (mkLit doubleDataCon (HsDoublePrim noExtField f)) + | otherwise = Nothing -shortCutLit _ (HsIsString src s) ty - | isStringTy ty = Just (HsLit noExtField (HsString src s)) - | otherwise = Nothing + go_string src s + | isStringTy res_ty = Just (HsLit noExtField (HsString src s)) + | otherwise = Nothing mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc mkLit con lit = HsApp noExtField (nlHsDataCon con) (nlHsLit lit) @@ -881,13 +929,10 @@ zonkExpr env (HsDo ty do_or_lc (L l stmts)) new_ty <- zonkTcTypeToTypeX env ty return (HsDo new_ty do_or_lc (L l new_stmts)) -zonkExpr env (ExplicitList ty wit exprs) - = do (env1, new_wit) <- zonkWit env wit - new_ty <- zonkTcTypeToTypeX env1 ty - new_exprs <- zonkLExprs env1 exprs - return (ExplicitList new_ty new_wit new_exprs) - where zonkWit env Nothing = return (env, Nothing) - zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln +zonkExpr env (ExplicitList ty exprs) + = do new_ty <- zonkTcTypeToTypeX env ty + new_exprs <- zonkLExprs env exprs + return (ExplicitList new_ty new_exprs) zonkExpr env expr@(RecordCon { rcon_ext = con_expr, rcon_flds = rbinds }) = do { new_con_expr <- zonkExpr env con_expr |