Commit f16dbbbe authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Major change in compilation of instance declarations (fix Trac #955, #2328)

This patch makes an important change to the way that dictionary
functions are handled.  Before, they were unconditionally marked
INLIINE, but all the code written by the user in the instance
was inside that unconditionally-inlined function.  Result: massive
code bloat in programs that use complicated instances.

This patch make instances behave rather as if all the methods
were written in separate definitions.  That dramatically reduces
bloat.  The new plan is described in TcInstDcls
	Note [How instance declarations are translated]

Everything validates.  The major code-bloat bug is squashed: in particular
DoCon is fine now (Trac #2328) and I believe that #955 is also better.

Nofib results:

Binary sizes
        -1 s.d.      +2.5%
        +1 s.d.      +3.1%
        Average      +2.8%

Allocations
        -1 s.d.      -6.4%
        +1 s.d.      +2.5%
        Average      -2.0%

Note that 2% improvement.  Some programs improve by 20% (rewrite)!
Two get slightly worse: pic (2.1%), and gameteb (3.2%), but all others
improve or stay the same.

I am not absolutely 100% certain that all the corners are correct; for
example, when default methods are marked INLINE, are they inlined?  But
overall it's better.

It's nice that the patch also removes a lot of code.  I deleted some
out of date comments, but there's something like 100 fewer lines of
code in the new version!  (In the line counts below, there are a lot
of new comments.)
parent 78260da4
......@@ -587,8 +587,11 @@ dsCoercion (WpLam id) thing_inside = do { expr <- thing_inside
; return (Lam id expr) }
dsCoercion (WpTyLam tv) thing_inside = do { expr <- thing_inside
; return (Lam tv expr) }
dsCoercion (WpApp id) thing_inside = do { expr <- thing_inside
; return (App expr (Var id)) }
dsCoercion (WpApp v) thing_inside
| isTyVar v = do { expr <- thing_inside
{- Probably a coercion var -} ; return (App expr (Type (mkTyVarTy v))) }
| otherwise = do { expr <- thing_inside
{- An Id -} ; return (App expr (Var v)) }
dsCoercion (WpTyApp ty) thing_inside = do { expr <- thing_inside
; return (App expr (Type ty)) }
dsCoercion WpInline thing_inside = do { expr <- thing_inside
......
......@@ -340,7 +340,7 @@ data HsWrapper
| WpCast Coercion -- A cast: [] `cast` co
-- Guaranteed not the identity coercion
| WpApp Var -- [] d the 'd' is a type-class dictionary
| WpApp Var -- [] d the 'd' is a type-class dictionary or coercion variable
| WpTyApp Type -- [] t the 't' is a type or corecion
| WpLam Var -- \d. [] the 'd' is a type-class dictionary or coercion variable
| WpTyLam TyVar -- \a. [] the 'a' is a type variable (not coercion var)
......
......@@ -123,8 +123,7 @@ tc_cmd env (HsLet binds (L body_loc body)) res_ty
tc_cmd env in_cmd@(HsCase scrut matches) (stk, res_ty)
= addErrCtxt (cmdCtxt in_cmd) $ do
(scrut', scrut_ty) <- addErrCtxt (caseScrutCtxt scrut) $
tcInferRho scrut
(scrut', scrut_ty) <- tcInferRho scrut
matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty
return (HsCase scrut' matches')
where
......@@ -341,10 +340,6 @@ arrowTyConKind = mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind
cmdCtxt :: HsExpr Name -> SDoc
cmdCtxt cmd = ptext (sLit "In the command:") <+> ppr cmd
caseScrutCtxt :: LHsExpr Name -> SDoc
caseScrutCtxt cmd
= hang (ptext (sLit "In the scrutinee of a case command:")) 4 (ppr cmd)
nonEmptyCmdStkErr :: HsExpr Name -> SDoc
nonEmptyCmdStkErr cmd
= hang (ptext (sLit "Non-empty command stack at command:"))
......
......@@ -6,7 +6,7 @@
\begin{code}
module TcBinds ( tcLocalBinds, tcTopBinds,
tcHsBootSigs, tcMonoBinds,
tcHsBootSigs, tcMonoBinds, tcPolyBinds,
TcPragFun, tcSpecPrag, tcPrags, mkPragFun,
TcSigInfo(..), TcSigFun, mkTcSigFun,
badBootDeclErr ) where
......@@ -165,26 +165,29 @@ tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside
-- the Ids declared with type signatures
; poly_rec <- doptM Opt_RelaxedPolyRec
; (binds', thing) <- tcExtendIdEnv poly_ids $
tc_val_binds poly_rec top_lvl sig_fn prag_fn
tcBindGroups poly_rec top_lvl sig_fn prag_fn
binds thing_inside
; return (ValBindsOut binds' sigs, thing) }
------------------------
tc_val_binds :: Bool -> TopLevelFlag -> TcSigFun -> TcPragFun
tcBindGroups :: Bool -> TopLevelFlag -> TcSigFun -> TcPragFun
-> [(RecFlag, LHsBinds Name)] -> TcM thing
-> TcM ([(RecFlag, LHsBinds TcId)], thing)
-- Typecheck a whole lot of value bindings,
-- one strongly-connected component at a time
-- Here a "strongly connected component" has the strightforward
-- meaning of a group of bindings that mention each other,
-- ignoring type signatures (that part comes later)
tc_val_binds _ _ _ _ [] thing_inside
tcBindGroups _ _ _ _ [] thing_inside
= do { thing <- thing_inside
; return ([], thing) }
tc_val_binds poly_rec top_lvl sig_fn prag_fn (group : groups) thing_inside
tcBindGroups poly_rec top_lvl sig_fn prag_fn (group : groups) thing_inside
= do { (group', (groups', thing))
<- tc_group poly_rec top_lvl sig_fn prag_fn group $
tc_val_binds poly_rec top_lvl sig_fn prag_fn groups thing_inside
tcBindGroups poly_rec top_lvl sig_fn prag_fn groups thing_inside
; return (group' ++ groups', thing) }
------------------------
......@@ -209,12 +212,12 @@ tc_group poly_rec top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
; return ([(Recursive, unionManyBags binds1)], thing) }
| otherwise -- Recursive group, with gla-exts
= -- To maximise polymorphism (with -fglasgow-exts), we do a new
= -- To maximise polymorphism (with -XRelaxedPolyRec), we do a new
-- strongly-connected-component analysis, this time omitting
-- any references to variables with type signatures.
--
-- Notice that the bindInsts thing covers *all* the bindings in the original
-- group at once; an earlier one may use a later one!
-- Notice that the bindInsts thing covers *all* the bindings in
-- the original group at once; an earlier one may use a later one!
do { traceTc (text "tc_group rec" <+> pprLHsBinds binds)
; (binds1,thing) <- bindLocalInsts top_lvl $
go (stronglyConnCompFromEdgedVertices (mkEdges sig_fn binds))
......@@ -560,8 +563,14 @@ tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf,
-- Note that the scoped_tvs and the (sig_tvs sig)
-- may have different Names. That's quite ok.
; traceTc (text "tcMoonBinds" <+> ppr scoped_tvs $$ ppr tc_sig)
; (co_fn, matches') <- tcExtendTyVarEnv2 rhs_tvs $
tcMatchesFun mono_name inf matches mono_ty
-- Note that "mono_ty" might actually be a polymorphic type,
-- if the original function had a signature like
-- forall a. Eq a => forall b. Ord b => ....
-- But that's ok: tcMatchesFun can deal with that
-- It happens, too! See Note [Polymorphic methods] in TcClassDcl.
; let fun_bind' = FunBind { fun_id = L nm_loc mono_id,
fun_infix = inf, fun_matches = matches',
......@@ -1120,9 +1129,8 @@ tcInstSig :: Bool -> Name -> TcM TcSigInfo
tcInstSig use_skols name
= do { poly_id <- tcLookupId name -- Cannot fail; the poly ids are put into
-- scope when starting the binding group
; let skol_info = SigSkol (FunSigCtxt name)
inst_tyvars = tcInstSigTyVars use_skols skol_info
; (tvs, theta, tau) <- tcInstType inst_tyvars (idType poly_id)
; let skol_info = SigSkol (FunSigCtxt name)
; (tvs, theta, tau) <- tcInstSigType use_skols skol_info (idType poly_id)
; loc <- getInstLoc (SigOrigin skol_info)
; return (TcSigInfo { sig_id = poly_id,
sig_tvs = tvs, sig_theta = theta, sig_tau = tau,
......
This diff is collapsed.
......@@ -12,7 +12,7 @@
-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcInferRho, tcSyntaxOp ) where
module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcInferRho, tcInferRhoNC, tcSyntaxOp ) where
#include "HsVersions.h"
......@@ -79,20 +79,20 @@ tcPolyExpr, tcPolyExprNC
-- to do so himself.
tcPolyExpr expr res_ty
= addErrCtxt (exprCtxt (unLoc expr)) $
= addErrCtxt (exprCtxt expr) $
(do {traceTc (text "tcPolyExpr") ; tcPolyExprNC expr res_ty })
tcPolyExprNC expr res_ty
| isSigmaTy res_ty
= do { traceTc (text "tcPolyExprNC" <+> ppr res_ty)
; (gen_fn, expr') <- tcGen res_ty emptyVarSet (\_ -> tcPolyExprNC expr)
; (gen_fn, expr') <- tcGen res_ty emptyVarSet Nothing (tcPolyExprNC expr)
-- Note the recursive call to tcPolyExpr, because the
-- type may have multiple layers of for-alls
-- E.g. forall a. Eq a => forall b. Ord b => ....
; return (mkLHsWrap gen_fn expr') }
| otherwise
= tcMonoExpr expr res_ty
= tcMonoExprNC expr res_ty
---------------
tcPolyExprs :: [LHsExpr Name] -> [TcType] -> TcM [LHsExpr TcId]
......@@ -104,21 +104,27 @@ tcPolyExprs (expr:exprs) (ty:tys)
tcPolyExprs exprs tys = pprPanic "tcPolyExprs" (ppr exprs $$ ppr tys)
---------------
tcMonoExpr :: LHsExpr Name -- Expression to type check
-> BoxyRhoType -- Expected type (could be a type variable)
-- Definitely no foralls at the top
-- Can contain boxes, which will be filled in
-> TcM (LHsExpr TcId)
tcMonoExpr (L loc expr) res_ty
tcMonoExpr, tcMonoExprNC
:: LHsExpr Name -- Expression to type check
-> BoxyRhoType -- Expected type (could be a type variable)
-- Definitely no foralls at the top
-- Can contain boxes, which will be filled in
-> TcM (LHsExpr TcId)
tcMonoExpr expr res_ty
= addErrCtxt (exprCtxt expr) $
tcMonoExprNC expr res_ty
tcMonoExprNC (L loc expr) res_ty
= ASSERT( not (isSigmaTy res_ty) )
setSrcSpan loc $
do { expr' <- tcExpr expr res_ty
; return (L loc expr') }
---------------
tcInferRho :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
tcInferRho expr = tcInfer (tcMonoExpr expr)
tcInferRho, tcInferRhoNC :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
tcInferRho expr = tcInfer (tcMonoExpr expr)
tcInferRhoNC expr = tcInfer (tcMonoExprNC expr)
\end{code}
......@@ -130,6 +136,9 @@ tcInferRho expr = tcInfer (tcMonoExpr expr)
\begin{code}
tcExpr :: HsExpr Name -> BoxyRhoType -> TcM (HsExpr TcId)
tcExpr e res_ty | debugIsOn && isSigmaTy res_ty -- Sanity check
= pprPanic "tcExpr: sigma" (ppr res_ty $$ ppr e)
tcExpr (HsVar name) res_ty = tcId (OccurrenceOf name) name res_ty
tcExpr (HsLit lit) res_ty = do { let lit_ty = hsLitType lit
......@@ -137,7 +146,7 @@ tcExpr (HsLit lit) res_ty = do { let lit_ty = hsLitType lit
; return $ mkHsWrapCoI coi (HsLit lit)
}
tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExpr expr res_ty
tcExpr (HsPar expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty
; return (HsPar expr') }
tcExpr (HsSCC lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty
......@@ -191,9 +200,8 @@ tcExpr in_expr@(ExprWithTySig expr sig_ty) res_ty
= do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
-- Remember to extend the lexical type-variable environment
; (gen_fn, expr') <- tcGen sig_tc_ty emptyVarSet (\ skol_tvs res_ty ->
tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $
tcPolyExprNC expr res_ty)
; (gen_fn, expr') <- tcGen sig_tc_ty emptyVarSet (Just ExprSigCtxt) $
tcMonoExprNC expr
; co_fn <- tcSubExp ExprSigOrigin sig_tc_ty res_ty
; return (mkHsWrap co_fn (ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty)) }
......@@ -238,7 +246,7 @@ tcExpr in_expr@(SectionL arg1 lop@(L loc op)) res_ty
then do (op', [arg1']) <- tcApp op 1 (tcArgs lop [arg1]) res_ty
return (SectionL arg1' (L loc op'))
else do (co_fn, (op', arg1'))
<- subFunTys doc 1 res_ty
<- subFunTys doc 1 res_ty Nothing
$ \ [arg2_ty'] res_ty' ->
tcApp op 2 (tc_args arg2_ty') res_ty'
return (mkHsWrap co_fn (SectionL arg1' (L loc op')))
......@@ -256,7 +264,7 @@ tcExpr in_expr@(SectionL arg1 lop@(L loc op)) res_ty
-- \ x -> op x expr
tcExpr in_expr@(SectionR lop@(L loc op) arg2) res_ty
= do { (co_fn, (op', arg2')) <- subFunTys doc 1 res_ty $ \ [arg1_ty'] res_ty' ->
= do { (co_fn, (op', arg2')) <- subFunTys doc 1 res_ty Nothing $ \ [arg1_ty'] res_ty' ->
tcApp op 2 (tc_args arg1_ty') res_ty'
; return (mkHsWrap co_fn (SectionR (L loc op') arg2')) }
where
......@@ -286,8 +294,7 @@ tcExpr (HsCase scrut matches) exp_ty
--
-- But now, in the GADT world, we need to typecheck the scrutinee
-- first, to get type info that may be refined in the case alternatives
(scrut', scrut_ty) <- addErrCtxt (caseScrutCtxt scrut)
(tcInferRho scrut)
(scrut', scrut_ty) <- tcInferRho scrut
; traceTc (text "HsCase" <+> ppr scrut_ty)
; matches' <- tcMatchesCase match_ctxt scrut_ty matches exp_ty
......@@ -297,8 +304,7 @@ tcExpr (HsCase scrut matches) exp_ty
mc_body = tcBody }
tcExpr (HsIf pred b1 b2) res_ty
= do { pred' <- addErrCtxt (predCtxt pred) $
tcMonoExpr pred boolTy
= do { pred' <- tcMonoExpr pred boolTy
; b1' <- tcMonoExpr b1 res_ty
; b2' <- tcMonoExpr b2 res_ty
; return (HsIf pred' b1' b2') }
......@@ -1169,10 +1175,7 @@ checkMissingFields data_con rbinds
Boring and alphabetical:
\begin{code}
caseScrutCtxt expr
= hang (ptext (sLit "In the scrutinee of a case expression:")) 4 (ppr expr)
exprCtxt expr
exprCtxt (L _ expr)
= hang (ptext (sLit "In the expression:")) 4 (ppr expr)
fieldCtxt field_name
......@@ -1183,9 +1186,6 @@ funAppCtxt fun arg arg_no
quotes (ppr fun) <> text ", namely"])
4 (quotes (ppr arg))
predCtxt expr
= hang (ptext (sLit "In the predicate expression:")) 4 (ppr expr)
nonVanillaUpd tycon
= vcat [ptext (sLit "Record update for the non-Haskell-98 data type")
<+> quotes (pprSourceTyCon tycon)
......
......@@ -15,7 +15,7 @@ tcMonoExpr ::
-> BoxyRhoType
-> TcM (LHsExpr TcId)
tcInferRho ::
tcInferRho, tcInferRhoNC ::
LHsExpr Name
-> TcM (LHsExpr TcId, TcRhoType)
......
This diff is collapsed.
......@@ -33,8 +33,8 @@ module TcMType (
--------------------------------
-- Instantiation
tcInstTyVar, tcInstType, tcInstTyVars, tcInstBoxyTyVar,
tcInstSigTyVars,
tcInstSkolTyVar, tcInstSkolTyVars, tcInstSkolType,
tcInstSigType,
tcInstSkolTyVars, tcInstSkolType,
tcSkolSigType, tcSkolSigTyVars, occurCheckErr,
--------------------------------
......@@ -430,17 +430,17 @@ tcSkolSigTyVars :: SkolemInfo -> [TyVar] -> [TcTyVar]
tcSkolSigTyVars info tyvars = [ mkSkolTyVar (tyVarName tv) (tyVarKind tv) info
| tv <- tyvars ]
tcInstSkolTyVar :: SkolemInfo -> Maybe SrcSpan -> TyVar -> TcM TcTyVar
tcInstSkolTyVar :: SkolemInfo -> (Name -> SrcSpan) -> TyVar -> TcM TcTyVar
-- Instantiate the tyvar, using
-- * the occ-name and kind of the supplied tyvar,
-- * the unique from the monad,
-- * the location either from the tyvar (mb_loc = Nothing)
-- or from mb_loc (Just loc)
tcInstSkolTyVar info mb_loc tyvar
tcInstSkolTyVar info get_loc tyvar
= do { uniq <- newUnique
; let old_name = tyVarName tyvar
kind = tyVarKind tyvar
loc = mb_loc `orElse` getSrcSpan old_name
loc = get_loc old_name
new_name = mkInternalName uniq (nameOccName old_name) loc
; return (mkSkolTyVar new_name kind info) }
......@@ -448,12 +448,21 @@ tcInstSkolTyVars :: SkolemInfo -> [TyVar] -> TcM [TcTyVar]
-- Get the location from the monad
tcInstSkolTyVars info tyvars
= do { span <- getSrcSpanM
; mapM (tcInstSkolTyVar info (Just span)) tyvars }
; mapM (tcInstSkolTyVar info (const span)) tyvars }
tcInstSkolType :: SkolemInfo -> TcType -> TcM ([TcTyVar], TcThetaType, TcType)
-- Instantiate a type with fresh skolem constants
-- Binding location comes from the monad
tcInstSkolType info ty = tcInstType (tcInstSkolTyVars info) ty
tcInstSigType :: Bool -> SkolemInfo -> TcType -> TcM ([TcTyVar], TcThetaType, TcRhoType)
-- Instantiate with skolems or meta SigTvs; depending on use_skols
-- Always take location info from the supplied tyvars
tcInstSigType use_skols skol_info ty
= tcInstType (mapM inst_tyvar) ty
where
inst_tyvar | use_skols = tcInstSkolTyVar skol_info getSrcSpan
| otherwise = instMetaTyVar (SigTv skol_info)
\end{code}
......@@ -563,16 +572,6 @@ tcInstTyVars tyvars
%************************************************************************
\begin{code}
tcInstSigTyVars :: Bool -> SkolemInfo -> [TyVar] -> TcM [TcTyVar]
-- Instantiate with skolems or meta SigTvs; depending on use_skols
-- Always take location info from the supplied tyvars
tcInstSigTyVars use_skols skol_info tyvars
| use_skols
= mapM (tcInstSkolTyVar skol_info Nothing) tyvars
| otherwise
= mapM (instMetaTyVar (SigTv skol_info)) tyvars
zonkSigTyVar :: TcTyVar -> TcM TcTyVar
zonkSigTyVar sig_tv
| isSkolemTyVar sig_tv
......
......@@ -12,7 +12,7 @@ module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
tcDoStmt, tcMDoStmt, tcGuardStmt
) where
import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRho, tcMonoExpr, tcPolyExpr )
import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRhoNC, tcMonoExpr, tcPolyExpr )
import HsSyn
import TcRnMonad
......@@ -73,7 +73,7 @@ tcMatchesFun fun_name inf matches exp_ty
-- This is one of two places places we call subFunTys
-- The point is that if expected_y is a "hole", we want
-- to make pat_tys and rhs_ty as "holes" too.
; subFunTys doc n_pats exp_ty $ \ pat_tys rhs_ty ->
; subFunTys doc n_pats exp_ty (Just (FunSigCtxt fun_name)) $ \ pat_tys rhs_ty ->
tcMatches match_ctxt pat_tys rhs_ty matches
}
where
......@@ -105,7 +105,7 @@ tcMatchesCase ctxt scrut_ty matches res_ty
tcMatchLambda :: MatchGroup Name -> BoxyRhoType -> TcM (HsWrapper, MatchGroup TcId)
tcMatchLambda match res_ty
= subFunTys doc n_pats res_ty $ \ pat_tys rhs_ty ->
= subFunTys doc n_pats res_ty Nothing $ \ pat_tys rhs_ty ->
tcMatches match_ctxt pat_tys rhs_ty match
where
n_pats = matchGroupArity match
......@@ -267,7 +267,7 @@ tcDoStmts ctxt _ _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
tcBody :: LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr TcId)
tcBody body res_ty
= do { traceTc (text "tcBody" <+> ppr res_ty)
; body' <- tcPolyExpr body res_ty
; body' <- tcMonoExpr body res_ty
; return body'
}
\end{code}
......@@ -327,7 +327,7 @@ tcGuardStmt _ (ExprStmt guard _ _) res_ty thing_inside
; return (ExprStmt guard' noSyntaxExpr boolTy, thing) }
tcGuardStmt _ (BindStmt pat rhs _ _) res_ty thing_inside
= do { (rhs', rhs_ty) <- tcInferRho rhs
= do { (rhs', rhs_ty) <- tcInferRhoNC rhs -- Stmt has a context already
; (pat', thing) <- tcLamPat pat rhs_ty res_ty thing_inside
; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
......@@ -404,7 +404,7 @@ tcLcStmt m_tc ctxt (TransformStmt (stmts, binders) usingExpr maybeByExpr) elt_ty
return (usingExpr', Nothing)
Just byExpr -> do
-- We must infer a type such that e :: t and then check that usingExpr :: forall a. (a -> t) -> [a] -> [a]
(byExpr', tTy) <- tcInferRho byExpr
(byExpr', tTy) <- tcInferRhoNC byExpr
usingExpr' <- tcPolyExpr usingExpr (mkForAllTy alphaTyVar ((alphaTy `mkFunTy` tTy) `mkFunTy` (alphaListTy `mkFunTy` alphaListTy)))
return (usingExpr', Just byExpr')
......@@ -428,7 +428,7 @@ tcLcStmt m_tc ctxt (GroupStmt (stmts, bindersMap) groupByClause) elt_ty thing_in
tcPolyExpr usingExpr (mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListListTy)) >>= (return . GroupByNothing)
GroupBySomething eitherUsingExpr byExpr -> do
-- We must infer a type such that byExpr :: t
(byExpr', tTy) <- tcInferRho byExpr
(byExpr', tTy) <- tcInferRhoNC byExpr
-- If it exists, we then check that usingExpr :: forall a. (a -> t) -> [a] -> [[a]]
let expectedUsingType = mkForAllTy alphaTyVar ((alphaTy `mkFunTy` tTy) `mkFunTy` (alphaListTy `mkFunTy` alphaListListTy))
......@@ -464,7 +464,7 @@ tcLcStmt _ _ stmt _ _
tcDoStmt :: TcStmtChecker
tcDoStmt _ (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
= do { (rhs', rhs_ty) <- tcInferRho rhs
= do { (rhs', rhs_ty) <- tcInferRhoNC rhs
-- We should use type *inference* for the RHS computations,
-- becuase of GADTs.
-- do { pat <- rhs; <rest> }
......@@ -495,7 +495,7 @@ tcDoStmt _ (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
tcDoStmt _ (ExprStmt rhs then_op _) res_ty thing_inside
= do { (rhs', rhs_ty) <- tcInferRho rhs
= do { (rhs', rhs_ty) <- tcInferRhoNC rhs
-- Deal with rebindable syntax; (>>) :: rhs_ty -> new_res_ty -> res_ty
; (then_op', new_res_ty) <-
......
......@@ -41,7 +41,7 @@ module TcType (
-- Splitters
-- These are important because they do not look through newtypes
tcView,
tcSplitForAllTys, tcSplitPhiTy,
tcSplitForAllTys, tcSplitPhiTy, tcSplitPredFunTy_maybe,
tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcSplitFunTysN,
tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppArgs,
tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, repSplitAppTy_maybe,
......@@ -660,16 +660,24 @@ tcIsForAllTy ty | Just ty' <- tcView ty = tcIsForAllTy ty'
tcIsForAllTy (ForAllTy tv _) = not (isCoVar tv)
tcIsForAllTy _ = False
tcSplitPredFunTy_maybe :: Type -> Maybe (PredType, Type)
-- Split off the first predicate argument from a type
tcSplitPredFunTy_maybe ty | Just ty' <- tcView ty = tcSplitPredFunTy_maybe ty'
tcSplitPredFunTy_maybe (ForAllTy tv ty)
| isCoVar tv = Just (coVarPred tv, ty)
tcSplitPredFunTy_maybe (FunTy arg res)
| Just p <- tcSplitPredTy_maybe arg = Just (p, res)
tcSplitPredFunTy_maybe _
= Nothing
tcSplitPhiTy :: Type -> (ThetaType, Type)
tcSplitPhiTy ty = split ty ty []
where
split orig_ty ty tvs | Just ty' <- tcView ty = split orig_ty ty' tvs
split _ (ForAllTy tv ty) ts
| isCoVar tv = split ty ty (coVarPred tv : ts)
split _ (FunTy arg res) ts
| Just p <- tcSplitPredTy_maybe arg = split res res (p:ts)
split orig_ty _ ts = (reverse ts, orig_ty)
tcSplitPhiTy ty
= split ty []
where
split ty ts
= case tcSplitPredFunTy_maybe ty of
Just (pred, ty) -> split ty (pred:ts)
Nothing -> (reverse ts, ty)
tcSplitSigmaTy :: Type -> ([TyVar], ThetaType, Type)
tcSplitSigmaTy ty = case tcSplitForAllTys ty of
......
......@@ -79,7 +79,9 @@ tcInfer tc_infer = withBox openTypeKind tc_infer
subFunTys :: SDoc -- Something like "The function f has 3 arguments"
-- or "The abstraction (\x.e) takes 1 argument"
-> Arity -- Expected # of args
-> BoxyRhoType -- res_ty
-> BoxySigmaType -- res_ty
-> Maybe UserTypeCtxt -- Whether res_ty arises from a user signature
-- Only relevant if we encounter a sigma-type
-> ([BoxySigmaType] -> BoxyRhoType -> TcM a)
-> TcM (HsWrapper, a)
-- Attempt to decompse res_ty to have enough top-level arrows to
......@@ -108,7 +110,7 @@ subFunTys :: SDoc -- Something like "The function f has 3 arguments"
-}
subFunTys error_herald n_pats res_ty thing_inside
subFunTys error_herald n_pats res_ty mb_ctxt thing_inside
= loop n_pats [] res_ty
where
-- In 'loop', the parameter 'arg_tys' accumulates
......@@ -121,8 +123,8 @@ subFunTys error_herald n_pats res_ty thing_inside
| isSigmaTy res_ty -- Do this before checking n==0, because we
-- guarantee to return a BoxyRhoType, not a
-- BoxySigmaType
= do { (gen_fn, (co_fn, res)) <- tcGen res_ty emptyVarSet $ \ _ res_ty' ->
loop n args_so_far res_ty'
= do { (gen_fn, (co_fn, res)) <- tcGen res_ty emptyVarSet mb_ctxt $
loop n args_so_far
; return (gen_fn <.> co_fn, res) }
loop 0 args_so_far res_ty
......@@ -768,7 +770,7 @@ tc_sub1 orig act_sty act_ty exp_ib exp_sty exp_ty
if exp_ib then -- SKOL does not apply if exp_ty is inside a box
defer_to_boxy_matching orig act_sty act_ty exp_ib exp_sty exp_ty
else do
{ (gen_fn, co_fn) <- tcGen exp_ty act_tvs $ \ _ body_exp_ty ->
{ (gen_fn, co_fn) <- tcGen exp_ty act_tvs Nothing $ \ body_exp_ty ->
tc_sub orig act_sty act_ty False body_exp_ty body_exp_ty
; return (gen_fn <.> co_fn) }
}
......@@ -898,22 +900,17 @@ tcGen :: BoxySigmaType -- expected_ty
-> TcTyVarSet -- Extra tyvars that the universally
-- quantified tyvars of expected_ty
-- must not be unified
-> ([TcTyVar] -> BoxyRhoType -> TcM result)
-> Maybe UserTypeCtxt -- Just ctxt => this polytype arose directly from
-- a user type sig; bring tyvars into scope
-- Nothing => a higher order situation
-> (BoxyRhoType -> TcM result)
-> TcM (HsWrapper, result)
-- The expression has type: spec_ty -> expected_ty
tcGen expected_ty extra_tvs thing_inside -- We expect expected_ty to be a forall-type
-- If not, the call is a no-op
tcGen expected_ty extra_tvs mb_ctxt thing_inside -- We expect expected_ty to be a forall-type
-- If not, the call is a no-op
= do { traceTc (text "tcGen")
-- We want the GenSkol info in the skolemised type variables to
-- mention the *instantiated* tyvar names, so that we get a
-- good error message "Rigid variable 'a' is bound by (forall a. a->a)"
-- Hence the tiresome but innocuous fixM
; ((tvs', theta', rho'), skol_info) <- fixM (\ ~(_, skol_info) ->
do { (forall_tvs, theta, rho_ty) <- tcInstSkolType skol_info expected_ty
-- Get loation from monad, not from expected_ty
; let skol_info = GenSkol forall_tvs (mkPhiTy theta rho_ty)
; return ((forall_tvs, theta, rho_ty), skol_info) })
; ((tvs', theta', rho'), skol_info, scoped_tvs) <- instantiate expected_ty
; when debugIsOn $
traceTc (text "tcGen" <+> vcat [
......@@ -924,7 +921,11 @@ tcGen expected_ty extra_tvs thing_inside -- We expect expected_ty to be a
text "free_tvs" <+> ppr free_tvs])
-- Type-check the arg and unify with poly type
; (result, lie) <- getLIE (thing_inside tvs' rho')
; (result, lie) <- getLIE $
tcExtendTyVarEnv2 (scoped_tvs `zip` mkTyVarTys tvs') $
-- Extend the lexical type-variable environment
-- if we're in a user-type context
thing_inside rho'
-- Check that the "forall_tvs" havn't been constrained
-- The interesting bit here is that we must include the free variables
......@@ -951,6 +952,24 @@ tcGen expected_ty extra_tvs thing_inside -- We expect expected_ty to be a
; return (co_fn, result) }
where
free_tvs = tyVarsOfType expected_ty `unionVarSet` extra_tvs
instantiate :: TcType -> TcM (([TcTyVar],ThetaType,TcRhoType), SkolemInfo, [Name])
instantiate expected_ty
| Just ctxt <- mb_ctxt
= do { let skol_info = SigSkol ctxt
tv_names = map tyVarName (fst (tcSplitForAllTys expected_ty))
; stuff <- tcInstSigType True skol_info expected_ty
; return (stuff, skol_info, tv_names) }
| otherwise -- We want the GenSkol info in the skolemised type variables to
-- mention the *instantiated* tyvar names, so that we get a
-- good error message "Rigid variable 'a' is bound by (forall a. a->a)"
-- Hence the tiresome but innocuous fixM
= fixM $ \ ~(_, skol_info, _) ->
do { stuff@(forall_tvs, theta, rho_ty) <- tcInstSkolType skol_info expected_ty
-- Get loation from *monad*, not from expected_ty
; let skol_info = GenSkol forall_tvs (mkPhiTy theta rho_ty)
; return (stuff, skol_info, []) }
\end{code}
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment