Commit 49dbe605 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Major improvement to pattern bindings

This patch makes a number of related improvements

a) Implements the Haskell Prime semantics for pattern bindings
   (Trac #2357).  That is, a pattern binding p = e is typed
   just as if it had been written
        t = e
        f = case t of p -> f
        g = case t of p -> g
        ... etc ...
   where f,g are the variables bound by p. In paricular it's
   ok to say
      (f,g) = (\x -> x, \y -> True)
   and f and g will get propertly inferred types
      f :: a -> a
      g :: a -> Int

b) Eliminates the MonoPatBinds flag altogether.  (For the moment
   it is deprecated and has no effect.)  Pattern bindings are now
   generalised as per (a).  Fixes Trac #2187 and #4940, in the
   way the users wanted!

c) Improves the OutsideIn algorithm generalisation decision.
   Given a definition without a type signature (implying "infer
   the type"), the published algorithm rule is this:
      - generalise *top-level* functions, and
      - do not generalise *nested* functions
   The new rule is
      - generalise a binding whose free variables have
        Guaranteed Closed Types
      - do not generalise other bindings

   Generally, a top-level let-bound function has a Guaranteed
   Closed Type, and so does a nested function whose free vaiables
   are top-level functions, and so on. (However a top-level
   function that is bitten by the Monomorphism Restriction does
   not have a GCT.)

   Example:
     f x = let { foo y = y } in ...
   Here 'foo' has no free variables, so it is generalised despite
   being nested.

d) When inferring a type f :: ty for a definition f = e, check that
   the compiler would accept f :: ty as a type signature for that
   same definition.  The type is rejected precisely when the type
   is ambiguous.

   Example:
      class Wob a b where
        to :: a -> b
        from :: b -> a

      foo x = [x, to (from x)]
   GHC 7.0 would infer the ambiguous type
      foo :: forall a b. Wob a b => b -> [b]
   but that type would give an error whenever it is called; and
   GHC 7.0 would reject that signature if given by the
   programmer.  The new type checker rejects it up front.

   Similarly, with the advent of type families, ambiguous types are
   easy to write by mistake.  See Trac #1897 and linked tickets for
   many examples.  Eg
      type family F a :: *
      f ::: F a -> Int
      f x = 3
   This is rejected because (F a ~ F b) does not imply a~b.  Previously
   GHC would *infer* the above type for f, but was unable to check it.
   Now even the inferred type is rejected -- correctly.

The main implemenation mechanism is to generalise the abe_wrap
field of ABExport (in HsBinds), from [TyVar] to HsWrapper. This
beautiful generalisation turned out to make everything work nicely
with minimal programming effort.  All the work was fiddling around
the edges; the core change was easy!
parent 20ceffb6
......@@ -37,7 +37,6 @@ import Digraph
import TcType
import Type
import Coercion
import TysPrim ( anyTypeOfKind )
import CostCentre
import Module
import Id
......@@ -122,15 +121,17 @@ dsHsBind auto_scc (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty })
-- Non-recursive bindings come through this way
-- So do self-recursive bindings, and recursive bindings
-- that have been chopped up with type signatures
dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts
, abs_exports = [(tyvars, global, local, prags)]
dsHsBind auto_scc (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
, abs_exports = [export]
, abs_ev_binds = ev_binds, abs_binds = binds })
= ASSERT( all (`elem` tyvars) all_tyvars )
do { bind_prs <- ds_lhs_binds NoSccs binds
| ABE { abe_wrap = wrap, abe_poly = global
, abe_mono = local, abe_prags = prags } <- export
= do { bind_prs <- ds_lhs_binds NoSccs binds
; ds_ev_binds <- dsTcEvBinds ev_binds
; wrap_fn <- dsHsWrapper wrap
; let core_bind = Rec (fromOL bind_prs)
rhs = addAutoScc auto_scc global $
wrap_fn $ -- Usually the identity
mkLams tyvars $ mkLams dicts $
wrapDsEvBinds ds_ev_binds $
Let core_bind $
......@@ -144,14 +145,14 @@ dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts
; return (main_bind `consOL` spec_binds) }
dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts
dsHsBind auto_scc (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
, abs_exports = exports, abs_ev_binds = ev_binds
, abs_binds = binds })
= do { bind_prs <- ds_lhs_binds NoSccs binds
; ds_ev_binds <- dsTcEvBinds ev_binds
; let env = mkABEnv exports
do_one (lcl_id,rhs) | Just (_, gbl_id, _, _prags) <- lookupVarEnv env lcl_id
= (lcl_id, addAutoScc auto_scc gbl_id rhs)
do_one (lcl_id,rhs) | Just export <- lookupVarEnv env lcl_id
= (lcl_id, addAutoScc auto_scc (abe_poly export) rhs)
| otherwise = (lcl_id,rhs)
core_bind = Rec (map do_one (fromOL bind_prs))
......@@ -159,37 +160,27 @@ dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts
tup_expr = mkBigCoreVarTup locals
tup_ty = exprType tup_expr
poly_tup_rhs = mkLams all_tyvars $ mkLams dicts $
poly_tup_rhs = mkLams tyvars $ mkLams dicts $
wrapDsEvBinds ds_ev_binds $
Let core_bind $
tup_expr
locals = [local | (_, _, local, _) <- exports]
local_tys = map idType locals
locals = map abe_mono exports
; poly_tup_id <- newSysLocalDs (exprType poly_tup_rhs)
; let mk_bind ((tyvars, global, _, spec_prags), n) -- locals!!n == local
= -- Need to make fresh locals to bind in the selector,
-- because some of the tyvars will be bound to 'Any'
do { let ty_args = map mk_ty_arg all_tyvars
substitute = substTyWith all_tyvars ty_args
; locals' <- newSysLocalsDs (map substitute local_tys)
; tup_id <- newSysLocalDs (substitute tup_ty)
; let rhs = mkLams tyvars $ mkLams dicts $
mkTupleSelector locals' (locals' !! n) tup_id $
mkVarApps (mkTyApps (Var poly_tup_id) ty_args)
dicts
full_rhs = Let (NonRec poly_tup_id poly_tup_rhs) rhs
; (spec_binds, rules) <- dsSpecs full_rhs spec_prags
; let mk_bind (ABE { abe_wrap = wrap, abe_poly = global
, abe_mono = local, abe_prags = spec_prags })
= do { wrap_fn <- dsHsWrapper wrap
; tup_id <- newSysLocalDs tup_ty
; let rhs = wrap_fn $ mkLams tyvars $ mkLams dicts $
mkTupleSelector locals local tup_id $
mkVarApps (Var poly_tup_id) (tyvars ++ dicts)
rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs
; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags
; let global' = addIdSpecialisations global rules
; return ((global', rhs) `consOL` spec_binds) }
where
mk_ty_arg all_tyvar
| all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
| otherwise = dsMkArbitraryType all_tyvar
; export_binds_s <- mapM mk_bind (exports `zip` [0..])
; export_binds_s <- mapM mk_bind exports
-- Don't scc (auto-)annotate the tuple itself.
; return ((poly_tup_id, poly_tup_rhs) `consOL`
......@@ -311,14 +302,14 @@ dictArity dicts = count isId dicts
------------------------
type AbsBindEnv = VarEnv ([TyVar], Id, Id, TcSpecPrags)
type AbsBindEnv = VarEnv (ABExport Id)
-- Maps the "lcl_id" for an AbsBind to
-- its "gbl_id" and associated pragmas, if any
mkABEnv :: [([TyVar], Id, Id, TcSpecPrags)] -> AbsBindEnv
mkABEnv :: [ABExport Id] -> AbsBindEnv
-- Takes the exports of a AbsBinds, and returns a mapping
-- lcl_id -> (tyvars, gbl_id, lcl_id, prags)
mkABEnv exports = mkVarEnv [ (lcl_id, export) | export@(_, _, lcl_id, _) <- exports]
mkABEnv exports = mkVarEnv [ (abe_mono export, export) | export <- exports]
\end{code}
Note [Rules and inlining]
......@@ -560,9 +551,6 @@ specUnfolding wrap_fn spec_ty (DFunUnfolding _ _ ops)
-}
specUnfolding _ _ _
= return (noUnfolding, nilOL)
dsMkArbitraryType :: TcTyVar -> Type
dsMkArbitraryType tv = anyTypeOfKind (tyVarKind tv)
\end{code}
%************************************************************************
......
......@@ -136,7 +136,7 @@ dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
, abs_binds = binds }) body
= do { ds_ev_binds <- dsTcEvBinds ev_binds
; let body1 = foldr bind_export body exports
bind_export (_, g, l, _) b = bindNonRec g (Var l) b
bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b
; body2 <- foldlBagM (\body bind -> dsStrictBind (unLoc bind) body)
body1 binds
; return (wrapDsEvBinds ds_ev_binds body2) }
......@@ -542,8 +542,8 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
= nlHsVar (lookupNameEnv upd_fld_env field_name `orElse` pat_arg_id)
inst_con = noLoc $ HsWrap wrap (HsVar (dataConWrapId con))
-- Reconstruct with the WrapId so that unpacking happens
wrap = mkWpEvVarApps theta_vars `WpCompose`
mkWpTyApps (mkTyVarTys ex_tvs) `WpCompose`
wrap = mkWpEvVarApps theta_vars <.>
mkWpTyApps (mkTyVarTys ex_tvs) <.>
mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys
, not (tv `elemVarEnv` wrap_subst) ]
rhs = foldl (\a b -> nlHsApp a b) inst_con val_args
......
......@@ -150,7 +150,7 @@ data HsBindLR idL idR
-- AbsBinds only gets used when idL = idR after renaming,
-- but these need to be idL's for the collect... code in HsUtil
-- to have the right type
abs_exports :: [([TyVar], idL, idL, TcSpecPrags)], -- (tvs, poly_id, mono_id, prags)
abs_exports :: [ABExport idL],
abs_ev_binds :: TcEvBinds, -- Evidence bindings
abs_binds :: LHsBinds idL -- Typechecked user bindings
......@@ -171,6 +171,14 @@ data HsBindLR idL idR
-- (You can get a PhD for explaining the True Meaning
-- of this last construct.)
data ABExport id
= ABE { abe_poly :: id
, abe_mono :: id
, abe_wrap :: HsWrapper -- See Note [AbsBinds wrappers]
-- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly
, abe_prags :: TcSpecPrags }
deriving (Data, Typeable)
placeHolderNames :: NameSet
-- Used for the NameSet in FunBind and PatBind prior to the renamer
placeHolderNames = panic "placeHolderNames"
......@@ -306,17 +314,19 @@ ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
= sep [ptext (sLit "AbsBinds"),
brackets (interpp'SP tyvars),
brackets (interpp'SP dictvars),
brackets (sep (punctuate comma (map ppr_exp exports)))]
brackets (sep (punctuate comma (map ppr exports)))]
$$
nest 2 ( vcat [pprBndr LetBind x | (_,x,_,_) <- exports]
nest 2 ( vcat [pprBndr LetBind (abe_poly ex) | ex <- exports]
-- Print type signatures
$$ pprLHsBinds val_binds )
$$
ifPprDebug (ppr ev_binds)
where
ppr_exp (tvs, gbl, lcl, prags)
= vcat [ppr gbl <+> ptext (sLit "<=") <+> ppr tvs <+> ppr lcl,
nest 2 (pprTcSpecPrags prags)]
instance (OutputableBndr id) => Outputable (ABExport id) where
ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags })
= vcat [ ppr gbl <+> ptext (sLit "<=") <+> ppr lcl
, nest 2 (pprTcSpecPrags prags)
, nest 2 (ppr wrap)]
\end{code}
......@@ -513,12 +523,12 @@ mkWpLet (EvBinds b) | isEmptyBag b = WpHole
mkWpLet ev_binds = WpLet ev_binds
mk_co_lam_fn :: (a -> HsWrapper) -> [a] -> HsWrapper
mk_co_lam_fn f as = foldr (\x wrap -> f x `WpCompose` wrap) WpHole as
mk_co_lam_fn f as = foldr (\x wrap -> f x <.> wrap) WpHole as
mk_co_app_fn :: (a -> HsWrapper) -> [a] -> HsWrapper
-- For applications, the *first* argument must
-- come *last* in the composition sequence
mk_co_app_fn f as = foldr (\x wrap -> wrap `WpCompose` f x) WpHole as
mk_co_app_fn f as = foldr (\x wrap -> wrap <.> f x) WpHole as
idHsWrapper :: HsWrapper
idHsWrapper = WpHole
......
......@@ -29,7 +29,7 @@ module HsUtils(
mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
-- Bindings
mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind,
mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind,
-- Literals
mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString,
......@@ -407,14 +407,23 @@ missingTupArg = Missing placeHolderType
%************************************************************************
\begin{code}
mkFunBind :: Located id -> [LMatch id] -> HsBind id
mkFunBind :: Located RdrName -> [LMatch RdrName] -> HsBind RdrName
-- Not infix, with place holders for coercion and free vars
mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False, fun_matches = mkMatchGroup ms,
fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames,
fun_tick = Nothing }
mkHsVarBind :: SrcSpan -> id -> LHsExpr id -> LHsBind id
mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False
, fun_matches = mkMatchGroup ms
, fun_co_fn = idHsWrapper
, bind_fvs = placeHolderNames
, fun_tick = Nothing }
mkTopFunBind :: Located Name -> [LMatch Name] -> HsBind Name
-- In Name-land, with empty bind_fvs
mkTopFunBind fn ms = FunBind { fun_id = fn, fun_infix = False
, fun_matches = mkMatchGroup ms
, fun_co_fn = idHsWrapper
, bind_fvs = emptyNameSet -- NB: closed binding
, fun_tick = Nothing }
mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
mkVarBind :: id -> LHsExpr id -> LHsBind id
......@@ -422,9 +431,8 @@ mkVarBind var rhs = L (getLoc rhs) $
VarBind { var_id = var, var_rhs = rhs, var_inline = False }
------------
mk_easy_FunBind :: SrcSpan -> id -> [LPat id]
-> LHsExpr id -> LHsBind id
mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
-> LHsExpr RdrName -> LHsBind RdrName
mk_easy_FunBind loc fun pats expr
= L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds]
......@@ -483,7 +491,7 @@ collect_bind (PatBind { pat_lhs = p }) acc = collect_lpat p acc
collect_bind (FunBind { fun_id = L _ f }) acc = f : acc
collect_bind (VarBind { var_id = f }) acc = f : acc
collect_bind (AbsBinds { abs_exports = dbinds, abs_binds = _binds }) acc
= [dp | (_,dp,_,_) <- dbinds] ++ acc
= map abe_poly dbinds ++ acc
-- ++ foldr collect_bind acc binds
-- I don't think we want the binders from the nested binds
-- The only time we collect binders from a typechecked
......
......@@ -910,19 +910,15 @@ languageExtensions :: Maybe Language -> [ExtensionFlag]
languageExtensions Nothing
-- Nothing => the default case
= Opt_MonoPatBinds -- Experimentally, I'm making this non-standard
-- behaviour the default, to see if anyone notices
-- SLPJ July 06
-- In due course I'd like Opt_MonoLocalBinds to be on by default
-- But NB it's implied by GADTs etc
-- SLPJ September 2010
: Opt_NondecreasingIndentation -- This has been on by default for some time
= Opt_NondecreasingIndentation -- This has been on by default for some time
: delete Opt_DatatypeContexts -- The Haskell' committee decided to
-- remove datatype contexts from the
-- language:
-- http://www.haskell.org/pipermail/haskell-prime/2011-January/003335.html
(languageExtensions (Just Haskell2010))
-- NB: MonoPatBinds is no longer the default
languageExtensions (Just Haskell98)
= [Opt_ImplicitPrelude,
Opt_MonomorphismRestriction,
......@@ -1863,7 +1859,8 @@ xFlags = [
( "NPlusKPatterns", AlwaysAllowed, Opt_NPlusKPatterns, nop ),
( "DoAndIfThenElse", AlwaysAllowed, Opt_DoAndIfThenElse, nop ),
( "RebindableSyntax", AlwaysAllowed, Opt_RebindableSyntax, nop ),
( "MonoPatBinds", AlwaysAllowed, Opt_MonoPatBinds, nop ),
( "MonoPatBinds", AlwaysAllowed, Opt_MonoPatBinds,
\ turn_on -> when turn_on $ deprecate "Experimental feature now removed; has no effect" ),
( "ExplicitForAll", AlwaysAllowed, Opt_ExplicitForAll, nop ),
( "AlternativeLayoutRule", AlwaysAllowed, Opt_AlternativeLayoutRule, nop ),
( "AlternativeLayoutRuleTransitional",AlwaysAllowed, Opt_AlternativeLayoutRuleTransitional, nop ),
......
......@@ -334,8 +334,10 @@ rnLocalValBindsRHS :: NameSet -- names bound by the LHSes
rnLocalValBindsRHS bound_names binds
= rnValBindsRHS trim (Just bound_names) binds
where
trim fvs = intersectNameSet bound_names fvs
-- Only keep the names the names from this group
trim fvs = filterNameSet isInternalName fvs
-- Keep Internal Names; these are the non-top-level ones
-- As well as dependency analysis, we need these for the
-- MonoLocalBinds test in TcBinds.decideGeneralisationPlan
-- for local binds
-- wrapper that does both the left- and right-hand sides
......
......@@ -25,10 +25,11 @@ import TcHsType
import TcPat
import TcMType
import TcType
import Coercion
-- import Coercion
import TysPrim
import Id
import Var
import VarSet
import Name
import NameSet
import NameEnv
......@@ -158,7 +159,7 @@ but rather because we otherwise end up with constraints like this
Num alpha, Implic { wanted = alpha ~ Int }
The constraint solver solves alpha~Int by unification, but then
doesn't float that solved constraint out (it's not an unsolved
wanted. Result disaster: the (Num alpha) is again solved, this
wanted). Result disaster: the (Num alpha) is again solved, this
time by defaulting. No no no.
However [Oct 10] this is all handled automatically by the
......@@ -227,9 +228,10 @@ tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside
-- A single non-recursive binding
-- We want to keep non-recursive things non-recursive
-- so that we desugar unlifted bindings correctly
= do { (binds1, ids) <- tcPolyBinds top_lvl sig_fn prag_fn NonRecursive NonRecursive
(bagToList binds)
; thing <- tcExtendIdEnv ids thing_inside
= do { (binds1, ids, closed) <- tcPolyBinds top_lvl sig_fn prag_fn
NonRecursive NonRecursive
(bagToList binds)
; thing <- tcExtendLetEnv closed ids thing_inside
; return ( [(NonRecursive, binds1)], thing) }
tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
......@@ -247,8 +249,8 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
sccs = stronglyConnCompFromEdgedVertices (mkEdges sig_fn binds)
go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, [TcId], thing)
go (scc:sccs) = do { (binds1, ids1) <- tc_scc scc
; (binds2, ids2, thing) <- tcExtendIdEnv ids1 $ go sccs
go (scc:sccs) = do { (binds1, ids1, closed) <- tc_scc scc
; (binds2, ids2, thing) <- tcExtendLetEnv closed ids1 $ go sccs
; return (binds1 `unionBags` binds2, ids1 ++ ids2, thing) }
go [] = do { thing <- thing_inside; return (emptyBag, [], thing) }
......@@ -257,25 +259,6 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
tc_sub_group = tcPolyBinds top_lvl sig_fn prag_fn Recursive
------------------------
{-
bindLocalInsts :: TopLevelFlag
-> TcM (LHsBinds TcId, [TcId], a)
-> TcM (LHsBinds TcId, TcEvBinds, a)
bindLocalInsts top_lvl thing_inside
| isTopLevel top_lvl
= do { (binds, _, thing) <- thing_inside; return (binds, emptyBag, thing) }
-- For the top level don't bother with all this bindInstsOfLocalFuns stuff.
-- All the top level things are rec'd together anyway, so it's fine to
-- leave them to the tcSimplifyTop, and quite a bit faster too
| otherwise -- Nested case
= do { ((binds, ids, thing), lie) <- captureConstraints thing_inside
; lie_binds <- bindLocalMethods lie ids
; return (binds, lie_binds, thing) }
-}
------------------------
mkEdges :: SigFun -> LHsBinds Name
-> [(LHsBind Name, BKey, [BKey])]
......@@ -309,7 +292,7 @@ tcPolyBinds :: TopLevelFlag -> SigFun -> PragFun
-> RecFlag -- Whether it's recursive after breaking
-- dependencies based on type signatures
-> [LHsBind Name]
-> TcM (LHsBinds TcId, [TcId])
-> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
-- Typechecks a single bunch of bindings all together,
-- and generalises them. The bunch may be only part of a recursive
......@@ -333,20 +316,22 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list
-- (as determined by sig_fn), returning a TcSigInfo for each
; tc_sig_fn <- tcInstSigs sig_fn binder_names
; dflags <- getDOpts
; let plan = decideGeneralisationPlan dflags top_lvl binder_names bind_list tc_sig_fn
; dflags <- getDOpts
; type_env <- getLclTypeEnv
; let plan = decideGeneralisationPlan dflags type_env
binder_names bind_list tc_sig_fn
; traceTc "Generalisation plan" (ppr plan)
; (binds, poly_ids) <- case plan of
NoGen -> tcPolyNoGen tc_sig_fn prag_fn rec_tc bind_list
InferGen mono -> tcPolyInfer top_lvl mono tc_sig_fn prag_fn rec_tc bind_list
CheckGen sig -> tcPolyCheck sig prag_fn rec_tc bind_list
; result@(_, poly_ids, _) <- case plan of
NoGen -> tcPolyNoGen tc_sig_fn prag_fn rec_tc bind_list
InferGen mn cl -> tcPolyInfer mn cl tc_sig_fn prag_fn rec_tc bind_list
CheckGen sig -> tcPolyCheck sig prag_fn rec_tc bind_list
-- Check whether strict bindings are ok
-- These must be non-recursive etc, and are not generalised
-- They desugar to a case expression in the end
; checkStrictBinds top_lvl rec_group bind_list poly_ids
; return (binds, poly_ids) }
; return result }
where
binder_names = collectHsBindListBinders bind_list
loc = foldr1 combineSrcSpans (map getLoc bind_list)
......@@ -360,14 +345,14 @@ tcPolyNoGen
-> RecFlag -- Whether it's recursive after breaking
-- dependencies based on type signatures
-> [LHsBind Name]
-> TcM (LHsBinds TcId, [TcId])
-> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
-- No generalisation whatsoever
tcPolyNoGen tc_sig_fn prag_fn rec_tc bind_list
= do { (binds', mono_infos) <- tcMonoBinds tc_sig_fn (LetGblBndr prag_fn)
rec_tc bind_list
; mono_ids' <- mapM tc_mono_info mono_infos
; return (binds', mono_ids') }
; return (binds', mono_ids', NotTopLevel) }
where
tc_mono_info (name, _, mono_id)
= do { mono_ty' <- zonkTcTypeCarefully (idType mono_id)
......@@ -385,68 +370,78 @@ tcPolyCheck :: TcSigInfo -> PragFun
-> RecFlag -- Whether it's recursive after breaking
-- dependencies based on type signatures
-> [LHsBind Name]
-> TcM (LHsBinds TcId, [TcId])
-> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
-- There is just one binding,
-- it binds a single variable,
-- it has a signature,
tcPolyCheck sig@(TcSigInfo { sig_id = id, sig_tvs = tvs, sig_scoped = scoped
tcPolyCheck sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs, sig_scoped = scoped
, sig_theta = theta, sig_tau = tau })
prag_fn rec_tc bind_list
= do { ev_vars <- newEvVars theta
; let skol_info = SigSkol (FunSigCtxt (idName id)) (mkPhiTy theta tau)
= do { loc <- getSrcSpanM
; ev_vars <- newEvVars theta
; let skol_info = SigSkol (FunSigCtxt (idName poly_id)) (mkPhiTy theta tau)
prag_sigs = prag_fn (idName poly_id)
; (ev_binds, (binds', [mono_info]))
<- checkConstraints skol_info tvs ev_vars $
tcExtendTyVarEnv2 (scoped `zip` mkTyVarTys tvs) $
tcMonoBinds (\_ -> Just sig) LetLclBndr rec_tc bind_list
; export <- mkExport prag_fn tvs theta mono_info
; spec_prags <- tcSpecPrags poly_id prag_sigs
; poly_id <- addInlinePrags poly_id prag_sigs
; loc <- getSrcSpanM
; let (_, poly_id, _, _) = export
; let (_, _, mono_id) = mono_info
export = ABE { abe_wrap = idHsWrapper
, abe_poly = poly_id
, abe_mono = mono_id
, abe_prags = SpecPrags spec_prags }
abs_bind = L loc $ AbsBinds
{ abs_tvs = tvs
, abs_ev_vars = ev_vars, abs_ev_binds = ev_binds
, abs_exports = [export], abs_binds = binds' }
; return (unitBag abs_bind, [poly_id]) }
closed | isEmptyVarSet (tyVarsOfType (idType poly_id)) = TopLevel
| otherwise = NotTopLevel
; return (unitBag abs_bind, [poly_id], closed) }
------------------
tcPolyInfer
:: TopLevelFlag
-> Bool -- True <=> apply the monomorphism restriction
:: Bool -- True <=> apply the monomorphism restriction
-> Bool -- True <=> free vars have closed types
-> TcSigFun -> PragFun
-> RecFlag -- Whether it's recursive after breaking
-- dependencies based on type signatures
-> [LHsBind Name]
-> TcM (LHsBinds TcId, [TcId])
tcPolyInfer top_lvl mono tc_sig_fn prag_fn rec_tc bind_list
-> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
tcPolyInfer mono closed tc_sig_fn prag_fn rec_tc bind_list
= do { ((binds', mono_infos), wanted)
<- captureConstraints $
tcMonoBinds tc_sig_fn LetLclBndr rec_tc bind_list
; unifyCtxts [sig | (_, Just sig, _) <- mono_infos]
; let name_taus = [(name, idType mono_id) | (name, _, mono_id) <- mono_infos]
; (qtvs, givens, ev_binds) <- simplifyInfer top_lvl mono name_taus wanted
; exports <- mapM (mkExport prag_fn qtvs (map evVarPred givens))
mono_infos
; (qtvs, givens, mr_bites, ev_binds) <- simplifyInfer closed mono name_taus wanted
; let poly_ids = [poly_id | (_, poly_id, _, _) <- exports]
; traceTc "Binding:" (ppr (poly_ids `zip` map idType poly_ids))
; theta <- zonkTcThetaType (map evVarPred givens)
; exports <- checkNoErrs $ mapM (mkExport prag_fn qtvs theta) mono_infos
; loc <- getSrcSpanM
; let abs_bind = L loc $ AbsBinds { abs_tvs = qtvs
, abs_ev_vars = givens, abs_ev_binds = ev_binds
, abs_exports = exports, abs_binds = binds' }
; let poly_ids = map abe_poly exports
final_closed | closed && not mr_bites = TopLevel
| otherwise = NotTopLevel
abs_bind = L loc $
AbsBinds { abs_tvs = qtvs
, abs_ev_vars = givens, abs_ev_binds = ev_binds
, abs_exports = exports, abs_binds = binds' }
; return (unitBag abs_bind, poly_ids) -- poly_ids are guaranteed zonked by mkExport
; traceTc "Binding:" (ppr (poly_ids `zip` map idType poly_ids))
; return (unitBag abs_bind, poly_ids, final_closed)
-- poly_ids are guaranteed zonked by mkExport
}
--------------
mkExport :: PragFun -> [TyVar] -> TcThetaType
mkExport :: PragFun
-> [TyVar] -> TcThetaType -- Both already zonked
-> MonoBindInfo
-> TcM ([TyVar], Id, Id, TcSpecPrags)
-> TcM (ABExport Id)
-- mkExport generates exports with
-- zonked type variables,
-- zonked poly_ids
......@@ -456,29 +451,61 @@ mkExport :: PragFun -> [TyVar] -> TcThetaType
-- The latter is needed because the poly_ids are used to extend the
-- type environment; see the invariant on TcEnv.tcExtendIdEnv
-- Pre-condition: the inferred_tvs are already zonked
-- Pre-condition: the qtvs and theta are already zonked
mkExport prag_fn inferred_tvs theta
(poly_name, mb_sig, mono_id)
= do { (tvs, poly_id) <- mk_poly_id mb_sig
-- poly_id has a zonked type
mkExport prag_fn qtvs theta (poly_name, mb_sig, mono_id)
= do { mono_ty <- zonkTcTypeCarefully (idType mono_id)
; let inferred_poly_ty = mkSigmaTy my_tvs theta mono_ty
my_tvs = filter (`elemVarSet` used_tvs) qtvs
used_tvs = tyVarsOfTheta theta `unionVarSet` tyVarsOfType mono_ty
; poly_id' <- addInlinePrags poly_id prag_sigs
poly_id = case mb_sig of
Nothing -> mkLocalId poly_name inferred_poly_ty
Just sig -> sig_id sig
-- poly_id has a zonked type
; poly_id <- addInlinePrags poly_id prag_sigs
; spec_prags <- tcSpecPrags poly_id prag_sigs
-- tcPrags requires a zonked poly_id
; return (tvs, poly_id', mono_id, SpecPrags spec_prags) }
; let sel_poly_ty = mkSigmaTy qtvs theta mono_ty
; traceTc "mkExport: check sig"
(ppr poly_name $$ ppr sel_poly_ty $$ ppr (idType poly_id))
-- Perform the impedence-matching and ambiguity check
-- right away. If it fails, we want to fail now (and recover
-- in tcPolyBinds). If we delay checking, we get an error cascade.
-- Remember we are in the tcPolyInfer case, so the type envt is
-- closed (unless we are doing NoMonoLocalBinds in which case all bets
-- are off)
; (wrap, wanted) <- addErrCtxtM (mk_msg poly_id) $
captureConstraints $
tcSubType origin sig_ctxt sel_poly_ty (idType poly_id)
; ev_binds <- simplifyAmbiguityCheck poly_name wanted
; return (ABE { abe_wrap = mkWpLet (EvBinds ev_binds) <.> wrap
, abe_poly = poly_id
, abe_mono = mono_id
, abe_prags = SpecPrags spec_prags }) }
where
prag_sigs = prag_fn poly_name
poly_ty = mkSigmaTy inferred_tvs theta (idType mono_id)
inferred = isNothing mb_sig
mk_poly_id Nothing = do { poly_ty' <- zonkTcTypeCarefully poly_ty
; return (inferred_tvs, mkLocalId poly_name poly_ty') }
mk_poly_id (Just sig) = do { tvs <- mapM zonk_tv (sig_tvs sig)
; return (tvs, sig_id sig) }
mk_msg poly_id tidy_env
= return (tidy_env', msg)
where
msg | inferred = hang (ptext (sLit "When checking that") <+> pp_name)
2 (ptext (sLit "has the inferred type") <+> pp_ty)
$$ ptext (sLit "Probable cause: the inferred type is ambiguous")
| otherwise = hang (ptext (sLit "When checking that") <+> pp_name)
2 (ptext (sLit "has the specified type") <+> pp_ty)
pp_name = quotes (ppr poly_name)
pp_ty = quotes (ppr tidy_ty)
(tidy_env', tidy_ty) = tidyOpenType tidy_env (idType poly_id)
zonk_tv tv = do { ty <- zonkTcTyVar tv; return (tcGetTyVar "mkExport" ty) }
prag_sigs = prag_fn poly_name
origin = AmbigOrigin poly_name
sig_ctxt = InfSigCtxt poly_name
------------------------
type PragFun = Name -> [LSig Name]
......@@ -627,12 +654,12 @@ tcVect (HsVect name@(L loc _) (Just rhs))
do { _id <- wrapLocM tcLookupId name -- need to ensure that the name is already defined
-- turn the vectorisation declaration into a single non-recursive binding
; let bind = L loc $ mkFunBind name [mkSimpleMatch [] rhs]
; let bind = L loc $ mkTopFunBind name [mkSimpleMatch [] rhs]
sigFun = const Nothing
pragFun = mkPragFun [] (unitBag bind)
-- perform type inference (including generalisation)
; (binds, [id']) <- tcPolyInfer TopLevel False sigFun pragFun NonRecursive [bind]
; (binds, [id'], _) <- tcPolyInfer False True sigFun pragFun NonRecursive [bind]
; traceTc "tcVect inferred type" $ ppr (varType id')
; traceTc "tcVect bindings" $ ppr binds
......@@ -663,11 +690,11 @@ vectCtxt name = ptext (sLit "When checking the vectorisation declaration for") <
-- If typechecking the binds fails, then return with each