2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcBinds]{TcBinds}
7 module TcBinds ( tcBindsAndThen, tcTopBindsAndThen,
8 tcPragmaSigs, tcBindWithSigs ) where
10 #include "HsVersions.h"
12 import {-# SOURCE #-} TcGRHSs ( tcGRHSsAndBinds )
13 import {-# SOURCE #-} TcExpr ( tcExpr )
15 import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), InPat(..), StmtCtxt(..),
16 collectMonoBinders, andMonoBindList, andMonoBinds
18 import RnHsSyn ( RenamedHsBinds, RenamedSig, RenamedMonoBinds )
19 import TcHsSyn ( TcHsBinds, TcMonoBinds,
20 TcIdOcc(..), TcIdBndr,
25 import Inst ( Inst, LIE, emptyLIE, mkLIE, plusLIE, plusLIEs, InstOrigin(..),
26 newDicts, tyVarsOfInst, instToId,
28 import TcEnv ( tcExtendLocalValEnv, tcExtendEnvWithPat,
31 tcGetGlobalTyVars, tcExtendGlobalTyVars
33 import TcMatches ( tcMatchesFun )
34 import TcSimplify ( tcSimplify, tcSimplifyAndCheck )
35 import TcMonoType ( tcHsTcType, checkSigTyVars,
36 TcSigInfo(..), tcTySig, maybeSig, sigCtxt
38 import TcPat ( tcVarPat, tcPat )
39 import TcSimplify ( bindInstsOfLocalFuns )
40 import TcType ( TcType, TcThetaType,
42 newTyVarTy, newTcTyVar, tcInstTcType,
43 zonkTcType, zonkTcTypes, zonkTcThetaType )
44 import TcUnify ( unifyTauTy, unifyTauTyLists )
46 import Id ( mkUserId )
47 import Var ( idType, idName, setIdInfo )
48 import IdInfo ( IdInfo, noIdInfo, setInlinePragInfo, InlinePragInfo(..) )
50 import Type ( mkTyVarTy, tyVarsOfTypes,
51 splitSigmaTy, mkForAllTys, mkFunTys, getTyVar,
52 mkDictTy, splitRhoTy, mkForAllTy, isUnLiftedType,
53 isUnboxedType, openTypeKind,
54 unboxedTypeKind, boxedTypeKind
56 import Var ( TyVar, tyVarKind )
60 import BasicTypes ( TopLevelFlag(..), RecFlag(..) )
61 import SrcLoc ( SrcLoc )
66 %************************************************************************
68 \subsection{Type-checking bindings}
70 %************************************************************************
72 @tcBindsAndThen@ typechecks a @HsBinds@. The "and then" part is because
73 it needs to know something about the {\em usage} of the things bound,
74 so that it can create specialisations of them. So @tcBindsAndThen@
75 takes a function which, given an extended environment, E, typechecks
76 the scope of the bindings returning a typechecked thing and (most
77 important) an LIE. It is this LIE which is then used as the basis for
78 specialising the things bound.
80 @tcBindsAndThen@ also takes a "combiner" which glues together the
81 bindings and the "thing" to make a new "thing".
83 The real work is done by @tcBindWithSigsAndThen@.
85 Recursive and non-recursive binds are handled in essentially the same
86 way: because of uniques there are no scoping issues left. The only
87 difference is that non-recursive bindings can bind primitive values.
89 Even for non-recursive binding groups we add typings for each binder
90 to the LVE for the following reason. When each individual binding is
91 checked the type of its LHS is unified with that of its RHS; and
92 type-checking the LHS of course requires that the binder is in scope.
94 At the top-level the LIE is sure to contain nothing but constant
95 dictionaries, which we resolve at the module level.
98 tcTopBindsAndThen, tcBindsAndThen
99 :: (RecFlag -> TcMonoBinds s -> thing -> thing) -- Combinator
101 -> TcM s (thing, LIE s)
102 -> TcM s (thing, LIE s)
104 tcTopBindsAndThen = tc_binds_and_then TopLevel
105 tcBindsAndThen = tc_binds_and_then NotTopLevel
107 tc_binds_and_then top_lvl combiner EmptyBinds do_next
109 tc_binds_and_then top_lvl combiner (MonoBind EmptyMonoBinds sigs is_rec) do_next
112 tc_binds_and_then top_lvl combiner (ThenBinds b1 b2) do_next
113 = tc_binds_and_then top_lvl combiner b1 $
114 tc_binds_and_then top_lvl combiner b2 $
117 tc_binds_and_then top_lvl combiner (MonoBind bind sigs is_rec) do_next
118 = fixTc (\ ~(prag_info_fn, _, _) ->
119 -- This is the usual prag_info fix; the PragmaInfo field of an Id
120 -- is not inspected till ages later in the compiler, so there
121 -- should be no black-hole problems here.
123 -- TYPECHECK THE SIGNATURES
124 mapTc tcTySig [sig | sig@(Sig name _ _) <- sigs] `thenTc` \ tc_ty_sigs ->
126 tcBindWithSigs top_lvl bind
127 tc_ty_sigs is_rec prag_info_fn `thenTc` \ (poly_binds, poly_lie, poly_ids) ->
129 -- Extend the environment to bind the new polymorphic Ids
130 tcExtendLocalValEnv (map idName poly_ids) poly_ids $
132 -- Build bindings and IdInfos corresponding to user pragmas
133 tcPragmaSigs sigs `thenTc` \ (prag_info_fn, prag_binds, prag_lie) ->
135 -- Now do whatever happens next, in the augmented envt
136 do_next `thenTc` \ (thing, thing_lie) ->
138 -- Create specialisations of functions bound here
139 -- We want to keep non-recursive things non-recursive
140 -- so that we desugar unboxed bindings correctly
141 case (top_lvl, is_rec) of
143 -- For the top level don't bother will all this bindInstsOfLocalFuns stuff
144 -- All the top level things are rec'd together anyway, so it's fine to
145 -- leave them to the tcSimplifyTop, and quite a bit faster too
147 -> returnTc (prag_info_fn,
148 combiner Recursive (poly_binds `andMonoBinds` prag_binds) thing,
149 thing_lie `plusLIE` prag_lie `plusLIE` poly_lie)
151 (NotTopLevel, NonRecursive)
152 -> bindInstsOfLocalFuns
153 (thing_lie `plusLIE` prag_lie)
154 poly_ids `thenTc` \ (thing_lie', lie_binds) ->
158 combiner NonRecursive poly_binds $
159 combiner NonRecursive prag_binds $
160 combiner Recursive lie_binds $
161 -- NB: the binds returned by tcSimplify and bindInstsOfLocalFuns
162 -- aren't guaranteed in dependency order (though we could change
163 -- that); hence the Recursive marker.
166 thing_lie' `plusLIE` poly_lie
169 (NotTopLevel, Recursive)
170 -> bindInstsOfLocalFuns
171 (thing_lie `plusLIE` poly_lie `plusLIE` prag_lie)
172 poly_ids `thenTc` \ (final_lie, lie_binds) ->
177 poly_binds `andMonoBinds`
178 lie_binds `andMonoBinds`
182 ) `thenTc` \ (_, thing, lie) ->
183 returnTc (thing, lie)
186 An aside. The original version of @tcBindsAndThen@ which lacks a
187 combiner function, appears below. Though it is perfectly well
188 behaved, it cannot be typed by Haskell, because the recursive call is
189 at a different type to the definition itself. There aren't too many
190 examples of this, which is why I thought it worth preserving! [SLPJ]
195 % -> TcM s (thing, LIE s, thing_ty))
196 % -> TcM s ((TcHsBinds s, thing), LIE s, thing_ty)
198 % tcBindsAndThen EmptyBinds do_next
199 % = do_next `thenTc` \ (thing, lie, thing_ty) ->
200 % returnTc ((EmptyBinds, thing), lie, thing_ty)
202 % tcBindsAndThen (ThenBinds binds1 binds2) do_next
203 % = tcBindsAndThen binds1 (tcBindsAndThen binds2 do_next)
204 % `thenTc` \ ((binds1', (binds2', thing')), lie1, thing_ty) ->
206 % returnTc ((binds1' `ThenBinds` binds2', thing'), lie1, thing_ty)
208 % tcBindsAndThen (MonoBind bind sigs is_rec) do_next
209 % = tcBindAndThen bind sigs do_next
213 %************************************************************************
215 \subsection{tcBindWithSigs}
217 %************************************************************************
219 @tcBindWithSigs@ deals with a single binding group. It does generalisation,
220 so all the clever stuff is in here.
222 * binder_names and mbind must define the same set of Names
224 * The Names in tc_ty_sigs must be a subset of binder_names
226 * The Ids in tc_ty_sigs don't necessarily have to have the same name
227 as the Name in the tc_ty_sig
236 -> TcM s (TcMonoBinds s, LIE s, [TcIdBndr s])
238 tcBindWithSigs top_lvl mbind tc_ty_sigs is_rec prag_info_fn
240 -- If typechecking the binds fails, then return with each
241 -- signature-less binder given type (forall a.a), to minimise subsequent
243 newTcTyVar boxedTypeKind `thenNF_Tc` \ alpha_tv ->
245 forall_a_a = mkForAllTy alpha_tv (mkTyVarTy alpha_tv)
246 binder_names = map fst (bagToList (collectMonoBinders mbind))
247 poly_ids = map mk_dummy binder_names
248 mk_dummy name = case maybeSig tc_ty_sigs name of
249 Just (TySigInfo _ poly_id _ _ _ _ _ _) -> poly_id -- Signature
250 Nothing -> mkUserId name forall_a_a -- No signature
252 returnTc (EmptyMonoBinds, emptyLIE, poly_ids)
255 -- TYPECHECK THE BINDINGS
256 tcMonoBinds mbind tc_ty_sigs is_rec `thenTc` \ (mbind', lie_req, binder_names, mono_ids) ->
259 mono_id_tys = map idType mono_ids
262 -- CHECK THAT THE SIGNATURES MATCH
263 -- (must do this before getTyVarsToGen)
264 checkSigMatch tc_ty_sigs `thenTc` \ (sig_theta, lie_avail) ->
266 -- COMPUTE VARIABLES OVER WHICH TO QUANTIFY, namely tyvars_to_gen
267 -- The tyvars_not_to_gen are free in the environment, and hence
268 -- candidates for generalisation, but sometimes the monomorphism
269 -- restriction means we can't generalise them nevertheless
270 getTyVarsToGen is_unrestricted mono_id_tys lie_req `thenNF_Tc` \ (tyvars_not_to_gen, tyvars_to_gen) ->
272 -- DEAL WITH TYPE VARIABLE KINDS
273 -- **** This step can do unification => keep other zonking after this ****
274 mapTc defaultUncommittedTyVar (varSetElems tyvars_to_gen) `thenTc` \ real_tyvars_to_gen_list ->
276 real_tyvars_to_gen = mkVarSet real_tyvars_to_gen_list
277 -- It's important that the final list
278 -- (real_tyvars_to_gen and real_tyvars_to_gen_list) is fully
279 -- zonked, *including boxity*, because they'll be included in the forall types of
280 -- the polymorphic Ids, and instances of these Ids will be generated from them.
282 -- Also NB that tcSimplify takes zonked tyvars as its arg, hence we pass
283 -- real_tyvars_to_gen
287 tcExtendGlobalTyVars tyvars_not_to_gen (
288 if null real_tyvars_to_gen_list then
289 -- No polymorphism, so no need to simplify context
290 returnTc (lie_req, EmptyMonoBinds, [])
292 if null tc_ty_sigs then
293 -- No signatures, so just simplify the lie
294 -- NB: no signatures => no polymorphic recursion, so no
295 -- need to use lie_avail (which will be empty anyway)
296 tcSimplify (text "tcBinds1" <+> ppr binder_names)
297 top_lvl real_tyvars_to_gen lie_req `thenTc` \ (lie_free, dict_binds, lie_bound) ->
298 returnTc (lie_free, dict_binds, map instToId (bagToList lie_bound))
301 zonkTcThetaType sig_theta `thenNF_Tc` \ sig_theta' ->
302 newDicts SignatureOrigin sig_theta' `thenNF_Tc` \ (dicts_sig, dict_ids) ->
303 -- It's important that sig_theta is zonked, because
304 -- dict_id is later used to form the type of the polymorphic thing,
305 -- and forall-types must be zonked so far as their bound variables
309 -- The "givens" is the stuff available. We get that from
310 -- the context of the type signature, BUT ALSO the lie_avail
311 -- so that polymorphic recursion works right (see comments at end of fn)
312 givens = dicts_sig `plusLIE` lie_avail
315 -- Check that the needed dicts can be expressed in
316 -- terms of the signature ones
317 tcAddErrCtxt (bindSigsCtxt tysig_names) $
319 (ptext SLIT("type signature for") <+> pprQuotedList binder_names)
320 real_tyvars_to_gen givens lie_req `thenTc` \ (lie_free, dict_binds) ->
322 returnTc (lie_free, dict_binds, dict_ids)
324 ) `thenTc` \ (lie_free, dict_binds, dicts_bound) ->
326 -- GET THE FINAL MONO_ID_TYS
327 zonkTcTypes mono_id_tys `thenNF_Tc` \ zonked_mono_id_types ->
330 -- CHECK FOR BOGUS UNPOINTED BINDINGS
331 (if any isUnLiftedType zonked_mono_id_types then
332 -- Unlifted bindings must be non-recursive,
333 -- not top level, and non-polymorphic
334 checkTc (case top_lvl of {TopLevel -> False; NotTopLevel -> True})
335 (unliftedBindErr "Top-level" mbind) `thenTc_`
336 checkTc (case is_rec of {Recursive -> False; NonRecursive -> True})
337 (unliftedBindErr "Recursive" mbind) `thenTc_`
338 checkTc (null real_tyvars_to_gen_list)
339 (unliftedBindErr "Polymorphic" mbind)
344 ASSERT( not (any ((== unboxedTypeKind) . tyVarKind) real_tyvars_to_gen_list) )
345 -- The instCantBeGeneralised stuff in tcSimplify should have
346 -- already raised an error if we're trying to generalise an
347 -- unboxed tyvar (NB: unboxed tyvars are always introduced
348 -- along with a class constraint) and it's better done there
349 -- because we have more precise origin information.
350 -- That's why we just use an ASSERT here.
353 -- BUILD THE POLYMORPHIC RESULT IDs
354 mapNF_Tc zonkId mono_ids `thenNF_Tc` \ zonked_mono_ids ->
356 exports = zipWith mk_export binder_names zonked_mono_ids
357 dict_tys = map tcIdType dicts_bound
359 mk_export binder_name zonked_mono_id
361 TcId (setIdInfo poly_id (prag_info_fn binder_name)),
365 case maybeSig tc_ty_sigs binder_name of
366 Just (TySigInfo _ sig_poly_id sig_tyvars _ _ _ _ _) ->
367 (sig_tyvars, sig_poly_id)
368 Nothing -> (real_tyvars_to_gen_list, new_poly_id)
370 new_poly_id = mkUserId binder_name poly_ty
371 poly_ty = mkForAllTys real_tyvars_to_gen_list
373 $ idType (zonked_mono_id)
374 -- It's important to build a fully-zonked poly_ty, because
375 -- we'll slurp out its free type variables when extending the
376 -- local environment (tcExtendLocalValEnv); if it's not zonked
377 -- it appears to have free tyvars that aren't actually free
380 pat_binders :: [Name]
381 pat_binders = map fst $ bagToList $ collectMonoBinders $
382 (justPatBindings mbind EmptyMonoBinds)
384 -- CHECK FOR UNBOXED BINDERS IN PATTERN BINDINGS
385 mapTc (\id -> checkTc (not (idName id `elem` pat_binders
386 && isUnboxedType (idType id)))
387 (unboxedPatBindErr id)) zonked_mono_ids
392 AbsBinds real_tyvars_to_gen_list
395 (dict_binds `andMonoBinds` mbind'),
397 [poly_id | (_, TcId poly_id, _) <- exports]
400 tysig_names = [name | (TySigInfo name _ _ _ _ _ _ _) <- tc_ty_sigs]
401 is_unrestricted = isUnRestrictedGroup tysig_names mbind
403 justPatBindings bind@(PatMonoBind _ _ _) binds = bind `andMonoBinds` binds
404 justPatBindings (AndMonoBinds b1 b2) binds =
405 justPatBindings b1 (justPatBindings b2 binds)
406 justPatBindings other_bind binds = binds
409 Polymorphic recursion
410 ~~~~~~~~~~~~~~~~~~~~~
411 The game plan for polymorphic recursion in the code above is
413 * Bind any variable for which we have a type signature
414 to an Id with a polymorphic type. Then when type-checking
415 the RHSs we'll make a full polymorphic call.
417 This fine, but if you aren't a bit careful you end up with a horrendous
418 amount of partial application and (worse) a huge space leak. For example:
420 f :: Eq a => [a] -> [a]
423 If we don't take care, after typechecking we get
425 f = /\a -> \d::Eq a -> let f' = f a d
429 Notice the the stupid construction of (f a d), which is of course
430 identical to the function we're executing. In this case, the
431 polymorphic recursion isn't being used (but that's a very common case).
434 f = /\a -> \d::Eq a -> letrec
435 fm = \ys:[a] -> ...fm...
439 This can lead to a massive space leak, from the following top-level defn
445 Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but
446 f' is another thunk which evaluates to the same thing... and you end
447 up with a chain of identical values all hung onto by the CAF ff.
451 = let f' = f Int dEqInt in \ys. ...f'...
453 = let f' = let f' = f Int dEqInt in \ys. ...f'...
457 Solution: when typechecking the RHSs we always have in hand the
458 *monomorphic* Ids for each binding. So we just need to make sure that
459 if (Method f a d) shows up in the constraints emerging from (...f...)
460 we just use the monomorphic Id. We achieve this by adding monomorphic Ids
461 to the "givens" when simplifying constraints. That's what the "lies_avail"
465 %************************************************************************
467 \subsection{getTyVarsToGen}
469 %************************************************************************
471 @getTyVarsToGen@ decides what type variables generalise over.
473 For a "restricted group" -- see the monomorphism restriction
474 for a definition -- we bind no dictionaries, and
475 remove from tyvars_to_gen any constrained type variables
477 *Don't* simplify dicts at this point, because we aren't going
478 to generalise over these dicts. By the time we do simplify them
479 we may well know more. For example (this actually came up)
481 f x = array ... xs where xs = [1,2,3,4,5]
482 We don't want to generate lots of (fromInt Int 1), (fromInt Int 2)
483 stuff. If we simplify only at the f-binding (not the xs-binding)
484 we'll know that the literals are all Ints, and we can just produce
487 Find all the type variables involved in overloading, the
488 "constrained_tyvars". These are the ones we *aren't* going to
489 generalise. We must be careful about doing this:
491 (a) If we fail to generalise a tyvar which is not actually
492 constrained, then it will never, ever get bound, and lands
493 up printed out in interface files! Notorious example:
494 instance Eq a => Eq (Foo a b) where ..
495 Here, b is not constrained, even though it looks as if it is.
496 Another, more common, example is when there's a Method inst in
497 the LIE, whose type might very well involve non-overloaded
500 (b) On the other hand, we mustn't generalise tyvars which are constrained,
501 because we are going to pass on out the unmodified LIE, with those
502 tyvars in it. They won't be in scope if we've generalised them.
504 So we are careful, and do a complete simplification just to find the
505 constrained tyvars. We don't use any of the results, except to
506 find which tyvars are constrained.
509 getTyVarsToGen is_unrestricted mono_id_tys lie
510 = tcGetGlobalTyVars `thenNF_Tc` \ free_tyvars ->
511 zonkTcTypes mono_id_tys `thenNF_Tc` \ zonked_mono_id_tys ->
513 tyvars_to_gen = tyVarsOfTypes zonked_mono_id_tys `minusVarSet` free_tyvars
517 returnNF_Tc (emptyVarSet, tyvars_to_gen)
519 -- This recover and discard-errs is to avoid duplicate error
520 -- messages; this, after all, is an "extra" call to tcSimplify
521 recoverNF_Tc (returnNF_Tc (emptyVarSet, tyvars_to_gen)) $
524 tcSimplify (text "getTVG") NotTopLevel tyvars_to_gen lie `thenTc` \ (_, _, constrained_dicts) ->
526 -- ASSERT: dicts_sig is already zonked!
527 constrained_tyvars = foldrBag (unionVarSet . tyVarsOfInst) emptyVarSet constrained_dicts
528 reduced_tyvars_to_gen = tyvars_to_gen `minusVarSet` constrained_tyvars
530 returnTc (constrained_tyvars, reduced_tyvars_to_gen)
535 isUnRestrictedGroup :: [Name] -- Signatures given for these
539 is_elem v vs = isIn "isUnResMono" v vs
541 isUnRestrictedGroup sigs (PatMonoBind (VarPatIn v) _ _) = v `is_elem` sigs
542 isUnRestrictedGroup sigs (PatMonoBind other _ _) = False
543 isUnRestrictedGroup sigs (VarMonoBind v _) = v `is_elem` sigs
544 isUnRestrictedGroup sigs (FunMonoBind _ _ _ _) = True
545 isUnRestrictedGroup sigs (AndMonoBinds mb1 mb2) = isUnRestrictedGroup sigs mb1 &&
546 isUnRestrictedGroup sigs mb2
547 isUnRestrictedGroup sigs EmptyMonoBinds = True
550 @defaultUncommittedTyVar@ checks for generalisation over unboxed
551 types, and defaults any TypeKind TyVars to BoxedTypeKind.
554 defaultUncommittedTyVar tyvar
555 | tyVarKind tyvar == openTypeKind
556 = newTcTyVar boxedTypeKind `thenNF_Tc` \ boxed_tyvar ->
557 unifyTauTy (mkTyVarTy tyvar) (mkTyVarTy boxed_tyvar) `thenTc_`
565 %************************************************************************
567 \subsection{tcMonoBind}
569 %************************************************************************
571 @tcMonoBinds@ deals with a single @MonoBind@.
572 The signatures have been dealt with already.
575 tcMonoBinds :: RenamedMonoBinds
578 -> TcM s (TcMonoBinds s,
579 LIE s, -- LIE required
580 [Name], -- Bound names
581 [TcIdBndr s]) -- Corresponding monomorphic bound things
583 tcMonoBinds mbinds tc_ty_sigs is_rec
584 = tc_mb_pats mbinds `thenTc` \ (complete_it, lie_req_pat, tvs, ids, lie_avail) ->
586 tv_list = bagToList tvs
587 (names, mono_ids) = unzip (bagToList ids)
589 -- Don't know how to deal with pattern-bound existentials yet
590 checkTc (isEmptyBag tvs && isEmptyBag lie_avail)
591 (existentialExplode mbinds) `thenTc_`
593 -- *Before* checking the RHSs, but *after* checking *all* the patterns,
594 -- extend the envt with bindings for all the bound ids;
595 -- and *then* override with the polymorphic Ids from the signatures
596 -- That is the whole point of the "complete_it" stuff.
597 tcExtendEnvWithPat ids (tcExtendEnvWithPat sig_ids
599 ) `thenTc` \ (mbinds', lie_req_rhss) ->
600 returnTc (mbinds', lie_req_pat `plusLIE` lie_req_rhss, names, mono_ids)
602 sig_fn name = case maybeSig tc_ty_sigs name of
604 Just (TySigInfo _ _ _ _ _ mono_id _ _) -> Just mono_id
606 sig_ids = listToBag [(name,poly_id) | TySigInfo name poly_id _ _ _ _ _ _ <- tc_ty_sigs]
608 kind = case is_rec of
609 Recursive -> boxedTypeKind -- Recursive, so no unboxed types
610 NonRecursive -> openTypeKind -- Non-recursive, so we permit unboxed types
612 tc_mb_pats EmptyMonoBinds
613 = returnTc (returnTc (EmptyMonoBinds, emptyLIE), emptyLIE, emptyBag, emptyBag, emptyLIE)
615 tc_mb_pats (AndMonoBinds mb1 mb2)
616 = tc_mb_pats mb1 `thenTc` \ (complete_it1, lie_req1, tvs1, ids1, lie_avail1) ->
617 tc_mb_pats mb2 `thenTc` \ (complete_it2, lie_req2, tvs2, ids2, lie_avail2) ->
619 complete_it = complete_it1 `thenTc` \ (mb1', lie1) ->
620 complete_it2 `thenTc` \ (mb2', lie2) ->
621 returnTc (AndMonoBinds mb1' mb2', lie1 `plusLIE` lie2)
623 returnTc (complete_it,
624 lie_req1 `plusLIE` lie_req2,
625 tvs1 `unionBags` tvs2,
626 ids1 `unionBags` ids2,
627 lie_avail1 `plusLIE` lie_avail2)
629 tc_mb_pats (FunMonoBind name inf matches locn)
630 = newTyVarTy boxedTypeKind `thenNF_Tc` \ pat_ty ->
631 tcVarPat sig_fn name pat_ty `thenTc` \ bndr_id ->
633 complete_it = tcAddSrcLoc locn $
634 tcMatchesFun name pat_ty matches `thenTc` \ (matches', lie) ->
635 returnTc (FunMonoBind (TcId bndr_id) inf matches' locn, lie)
637 returnTc (complete_it, emptyLIE, emptyBag, unitBag (name, bndr_id), emptyLIE)
639 tc_mb_pats bind@(PatMonoBind pat grhss_and_binds locn)
641 newTyVarTy kind `thenNF_Tc` \ pat_ty ->
642 tcPat sig_fn pat pat_ty `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
644 complete_it = tcAddSrcLoc locn $
645 tcAddErrCtxt (patMonoBindsCtxt bind) $
646 tcGRHSsAndBinds grhss_and_binds pat_ty PatBindRhs `thenTc` \ (grhss_and_binds', lie) ->
647 returnTc (PatMonoBind pat' grhss_and_binds' locn, lie)
649 returnTc (complete_it, lie_req, tvs, ids, lie_avail)
652 %************************************************************************
654 \subsection{Signatures}
656 %************************************************************************
658 @checkSigMatch@ does the next step in checking signature matching.
659 The tau-type part has already been unified. What we do here is to
660 check that this unification has not over-constrained the (polymorphic)
661 type variables of the original signature type.
663 The error message here is somewhat unsatisfactory, but it'll do for
668 = returnTc (error "checkSigMatch", emptyLIE)
670 checkSigMatch tc_ty_sigs@( sig1@(TySigInfo _ id1 _ theta1 _ _ _ _) : all_sigs_but_first )
671 = -- CHECK THAT THE SIGNATURE TYVARS AND TAU_TYPES ARE OK
672 -- Doesn't affect substitution
673 mapTc check_one_sig tc_ty_sigs `thenTc_`
675 -- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE UNIFIABLE
676 -- The type signatures on a mutually-recursive group of definitions
677 -- must all have the same context (or none).
679 -- We unify them because, with polymorphic recursion, their types
680 -- might not otherwise be related. This is a rather subtle issue.
682 mapTc check_one_cxt all_sigs_but_first `thenTc_`
684 returnTc (theta1, sig_lie)
686 sig1_dict_tys = mk_dict_tys theta1
687 n_sig1_dict_tys = length sig1_dict_tys
688 sig_lie = mkLIE [inst | TySigInfo _ _ _ _ _ _ inst _ <- tc_ty_sigs]
690 check_one_cxt sig@(TySigInfo _ id _ theta _ _ _ src_loc)
691 = tcAddSrcLoc src_loc $
692 tcAddErrCtxt (sigContextsCtxt id1 id) $
693 checkTc (length this_sig_dict_tys == n_sig1_dict_tys)
694 sigContextsErr `thenTc_`
695 unifyTauTyLists sig1_dict_tys this_sig_dict_tys
697 this_sig_dict_tys = mk_dict_tys theta
699 check_one_sig (TySigInfo _ id sig_tyvars _ sig_tau _ _ src_loc)
700 = tcAddSrcLoc src_loc $
701 tcAddErrCtxtM (sigCtxt (quotes (ppr id)) sig_tau) $
702 checkSigTyVars sig_tyvars
704 mk_dict_tys theta = [mkDictTy c ts | (c,ts) <- theta]
708 %************************************************************************
710 \subsection{SPECIALIZE pragmas}
712 %************************************************************************
715 @tcPragmaSigs@ munches up the "signatures" that arise through *user*
716 pragmas. It is convenient for them to appear in the @[RenamedSig]@
717 part of a binding because then the same machinery can be used for
718 moving them into place as is done for type signatures.
721 tcPragmaSigs :: [RenamedSig] -- The pragma signatures
722 -> TcM s (Name -> IdInfo, -- Maps name to the appropriate IdInfo
727 = mapAndUnzip3Tc tcPragmaSig sigs `thenTc` \ (maybe_info_modifiers, binds, lies) ->
729 prag_fn name = foldr ($) noIdInfo [f | Just (n,f) <- maybe_info_modifiers, n==name]
731 returnTc (prag_fn, andMonoBindList binds, plusLIEs lies)
734 The interesting case is for SPECIALISE pragmas. There are two forms.
735 Here's the first form:
737 f :: Ord a => [a] -> b -> b
738 {-# SPECIALIZE f :: [Int] -> b -> b #-}
741 For this we generate:
743 f* = /\ b -> let d1 = ...
747 where f* is a SpecPragmaId. The **sole** purpose of SpecPragmaIds is to
748 retain a right-hand-side that the simplifier will otherwise discard as
749 dead code... the simplifier has a flag that tells it not to discard
750 SpecPragmaId bindings.
752 In this case the f* retains a call-instance of the overloaded
753 function, f, (including appropriate dictionaries) so that the
754 specialiser will subsequently discover that there's a call of @f@ at
755 Int, and will create a specialisation for @f@. After that, the
756 binding for @f*@ can be discarded.
758 The second form is this:
760 f :: Ord a => [a] -> b -> b
761 {-# SPECIALIZE f :: [Int] -> b -> b = g #-}
764 Here @g@ is specified as a function that implements the specialised
765 version of @f@. Suppose that g has type (a->b->b); that is, g's type
766 is more general than that required. For this we generate
768 f@Int = /\b -> g Int b
772 Here @f@@Int@ is a SpecId, the specialised version of @f@. It inherits
773 f's export status etc. @f*@ is a SpecPragmaId, as before, which just serves
774 to prevent @f@@Int@ from being discarded prematurely. After specialisation,
775 if @f@@Int@ is going to be used at all it will be used explicitly, so the simplifier can
776 discard the f* binding.
778 Actually, there is really only point in giving a SPECIALISE pragma on exported things,
779 and the simplifer won't discard SpecIds for exporte things anyway, so maybe this is
783 tcPragmaSig :: RenamedSig -> TcM s (Maybe (Name, IdInfo -> IdInfo), TcMonoBinds s, LIE s)
784 tcPragmaSig (Sig _ _ _) = returnTc (Nothing, EmptyMonoBinds, emptyLIE)
785 tcPragmaSig (SpecInstSig _ _) = returnTc (Nothing, EmptyMonoBinds, emptyLIE)
787 tcPragmaSig (InlineSig name loc)
788 = returnTc (Just (name, setInlinePragInfo IWantToBeINLINEd), EmptyMonoBinds, emptyLIE)
790 tcPragmaSig (NoInlineSig name loc)
791 = returnTc (Just (name, setInlinePragInfo IMustNotBeINLINEd), EmptyMonoBinds, emptyLIE)
793 tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc)
794 = -- SPECIALISE f :: forall b. theta => tau = g
795 tcAddSrcLoc src_loc $
796 tcAddErrCtxt (valSpecSigCtxt name poly_ty) $
798 -- Get and instantiate its alleged specialised type
799 tcHsTcType poly_ty `thenTc` \ sig_ty ->
801 -- Check that f has a more general type, and build a RHS for
802 -- the spec-pragma-id at the same time
803 tcExpr (HsVar name) sig_ty `thenTc` \ (spec_expr, spec_lie) ->
805 case maybe_spec_name of
806 Nothing -> -- Just specialise "f" by building a SpecPragmaId binding
807 -- It is the thing that makes sure we don't prematurely
808 -- dead-code-eliminate the binding we are really interested in.
809 newSpecPragmaId name sig_ty `thenNF_Tc` \ spec_id ->
810 returnTc (Nothing, VarMonoBind (TcId spec_id) spec_expr, spec_lie)
812 Just g_name -> -- Don't create a SpecPragmaId. Instead add some suitable IdIfo
814 panic "Can't handle SPECIALISE with a '= g' part"
816 {- Not yet. Because we're still in the TcType world we
817 can't really add to the SpecEnv of the Id. Instead we have to
818 record the information in a different sort of Sig, and add it to
819 the IdInfo after zonking.
821 For now we just leave out this case
823 -- Get the type of f, and find out what types
824 -- f has to be instantiated at to give the signature type
825 tcLookupLocalValueOK "tcPragmaSig" name `thenNF_Tc` \ f_id ->
826 tcInstTcType (idType f_id) `thenNF_Tc` \ (f_tyvars, f_rho) ->
829 (sig_tyvars, sig_theta, sig_tau) = splitSigmaTy sig_ty
830 (f_theta, f_tau) = splitRhoTy f_rho
831 sig_tyvar_set = mkVarSet sig_tyvars
833 unifyTauTy sig_tau f_tau `thenTc_`
835 tcPolyExpr str (HsVar g_name) (mkSigmaTy sig_tyvars f_theta sig_tau) `thenTc` \ (_, _,
838 tcPragmaSig other = pprTrace "tcPragmaSig: ignoring" (ppr other) $
839 returnTc (Nothing, EmptyMonoBinds, emptyLIE)
843 %************************************************************************
845 \subsection[TcBinds-errors]{Error contexts and messages}
847 %************************************************************************
851 patMonoBindsCtxt bind
852 = hang (ptext SLIT("In a pattern binding:")) 4 (ppr bind)
854 -----------------------------------------------
856 = sep [ptext SLIT("In a SPECIALIZE pragma for a value:"),
857 nest 4 (ppr v <+> ptext SLIT(" ::") <+> ppr ty)]
859 -----------------------------------------------
860 notAsPolyAsSigErr sig_tau mono_tyvars
861 = hang (ptext SLIT("A type signature is more polymorphic than the inferred type"))
862 4 (vcat [text "Can't for-all the type variable(s)" <+>
863 pprQuotedList mono_tyvars,
864 text "in the type" <+> quotes (ppr sig_tau)
867 -----------------------------------------------
868 badMatchErr sig_ty inferred_ty
869 = hang (ptext SLIT("Type signature doesn't match inferred type"))
870 4 (vcat [hang (ptext SLIT("Signature:")) 4 (ppr sig_ty),
871 hang (ptext SLIT("Inferred :")) 4 (ppr inferred_ty)
874 -----------------------------------------------
876 = ptext SLIT("variable in a lazy pattern binding has unboxed type: ")
879 -----------------------------------------------
881 = ptext SLIT("When checking the type signature(s) for") <+> pprQuotedList ids
883 -----------------------------------------------
885 = ptext SLIT("Mismatched contexts")
886 sigContextsCtxt s1 s2
887 = hang (hsep [ptext SLIT("When matching the contexts of the signatures for"),
888 quotes (ppr s1), ptext SLIT("and"), quotes (ppr s2)])
889 4 (ptext SLIT("(the signature contexts in a mutually recursive group should all be identical)"))
891 -----------------------------------------------
892 unliftedBindErr flavour mbind
893 = hang (text flavour <+> ptext SLIT("bindings for unlifted types aren't allowed"))
896 existentialExplode mbinds
897 = hang (vcat [text "My brain just exploded.",
898 text "I can't handle pattern bindings for existentially-quantified constructors.",
899 text "In the binding group"])