2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[TcBinds]{TcBinds}
7 #include "HsVersions.h"
9 module TcBinds ( tcBindsAndThen, tcPragmaSigs ) where
13 import HsSyn ( HsBinds(..), Bind(..), Sig(..), MonoBinds(..),
14 HsExpr, Match, PolyType, InPat, OutPat,
15 GRHSsAndBinds, ArithSeqInfo, HsLit, Fake,
17 import RnHsSyn ( RenamedHsBinds(..), RenamedBind(..), RenamedSig(..),
18 RenamedMonoBinds(..) )
19 import TcHsSyn ( TcHsBinds(..), TcBind(..), TcMonoBinds(..),
20 TcIdOcc(..), TcIdBndr(..) )
23 import GenSpecEtc ( checkSigTyVars, genBinds, TcSigInfo(..) )
24 import Inst ( Inst, LIE(..), emptyLIE, plusLIE, InstOrigin(..) )
25 import TcEnv ( tcExtendLocalValEnv, tcLookupLocalValueOK, newMonoIds )
26 import TcLoop ( tcGRHSsAndBinds )
27 import TcMatches ( tcMatchesFun )
28 import TcMonoType ( tcPolyType )
29 import TcPat ( tcPat )
30 import TcSimplify ( bindInstsOfLocalFuns )
31 import TcType ( newTcTyVar, tcInstType )
32 import Unify ( unifyTauTy )
34 import Kind ( mkBoxedTypeKind, mkTypeKind )
35 import Id ( GenId, idType, mkUserId )
36 import IdInfo ( noIdInfo )
37 import Name ( Name ) -- instances
38 import Maybes ( assocMaybe, catMaybes, Maybe(..) )
39 import Outputable ( pprNonOp )
40 import PragmaInfo ( PragmaInfo(..) )
42 import Type ( mkTyVarTy, isTyVarTy, mkSigmaTy, splitSigmaTy,
43 splitRhoTy, mkForAllTy, splitForAllTy )
47 %************************************************************************
49 \subsection{Type-checking bindings}
51 %************************************************************************
53 @tcBindsAndThen@ typechecks a @HsBinds@. The "and then" part is because
54 it needs to know something about the {\em usage} of the things bound,
55 so that it can create specialisations of them. So @tcBindsAndThen@
56 takes a function which, given an extended environment, E, typechecks
57 the scope of the bindings returning a typechecked thing and (most
58 important) an LIE. It is this LIE which is then used as the basis for
59 specialising the things bound.
61 @tcBindsAndThen@ also takes a "combiner" which glues together the
62 bindings and the "thing" to make a new "thing".
64 The real work is done by @tcBindAndThen@.
66 Recursive and non-recursive binds are handled in essentially the same
67 way: because of uniques there are no scoping issues left. The only
68 difference is that non-recursive bindings can bind primitive values.
70 Even for non-recursive binding groups we add typings for each binder
71 to the LVE for the following reason. When each individual binding is
72 checked the type of its LHS is unified with that of its RHS; and
73 type-checking the LHS of course requires that the binder is in scope.
75 At the top-level the LIE is sure to contain nothing but constant
76 dictionaries, which we resolve at the module level.
80 :: (TcHsBinds s -> thing -> thing) -- Combinator
82 -> TcM s (thing, LIE s, thing_ty)
83 -> TcM s (thing, LIE s, thing_ty)
85 tcBindsAndThen combiner EmptyBinds do_next
86 = do_next `thenTc` \ (thing, lie, thing_ty) ->
87 returnTc (combiner EmptyBinds thing, lie, thing_ty)
89 tcBindsAndThen combiner (SingleBind bind) do_next
90 = tcBindAndThen combiner bind [] do_next
92 tcBindsAndThen combiner (BindWith bind sigs) do_next
93 = tcBindAndThen combiner bind sigs do_next
95 tcBindsAndThen combiner (ThenBinds binds1 binds2) do_next
96 = tcBindsAndThen combiner binds1 (tcBindsAndThen combiner binds2 do_next)
99 An aside. The original version of @tcBindsAndThen@ which lacks a
100 combiner function, appears below. Though it is perfectly well
101 behaved, it cannot be typed by Haskell, because the recursive call is
102 at a different type to the definition itself. There aren't too many
103 examples of this, which is why I thought it worth preserving! [SLPJ]
108 -> TcM s (thing, LIE s, thing_ty))
109 -> TcM s ((TcHsBinds s, thing), LIE s, thing_ty)
111 tcBindsAndThen EmptyBinds do_next
112 = do_next `thenTc` \ (thing, lie, thing_ty) ->
113 returnTc ((EmptyBinds, thing), lie, thing_ty)
115 tcBindsAndThen (SingleBind bind) do_next
116 = tcBindAndThen bind [] do_next
118 tcBindsAndThen (BindWith bind sigs) do_next
119 = tcBindAndThen bind sigs do_next
121 tcBindsAndThen (ThenBinds binds1 binds2) do_next
122 = tcBindsAndThen binds1 (tcBindsAndThen binds2 do_next)
123 `thenTc` \ ((binds1', (binds2', thing')), lie1, thing_ty) ->
125 returnTc ((binds1' `ThenBinds` binds2', thing'), lie1, thing_ty)
128 %************************************************************************
132 %************************************************************************
136 :: (TcHsBinds s -> thing -> thing) -- Combinator
137 -> RenamedBind -- The Bind to typecheck
138 -> [RenamedSig] -- ...and its signatures
139 -> TcM s (thing, LIE s, thing_ty) -- Thing to type check in
141 -> TcM s (thing, LIE s, thing_ty) -- Results, incl the
143 tcBindAndThen combiner bind sigs do_next
144 = fixTc (\ ~(prag_info_fn, _) ->
145 -- This is the usual prag_info fix; the PragmaInfo field of an Id
146 -- is not inspected till ages later in the compiler, so there
147 -- should be no black-hole problems here.
149 tcBindAndSigs binder_names bind
150 sigs prag_info_fn `thenTc` \ (poly_binds, poly_lie, poly_ids) ->
152 -- Extend the environment to bind the new polymorphic Ids
153 tcExtendLocalValEnv binder_names poly_ids $
155 -- Build bindings and IdInfos corresponding to user pragmas
156 tcPragmaSigs sigs `thenTc` \ (prag_info_fn, prag_binds, prag_lie) ->
158 -- Now do whatever happens next, in the augmented envt
159 do_next `thenTc` \ (thing, thing_lie, thing_ty) ->
161 -- Create specialisations of functions bound here
162 bindInstsOfLocalFuns (prag_lie `plusLIE` thing_lie)
163 poly_ids `thenTc` \ (lie2, inst_mbinds) ->
167 final_lie = lie2 `plusLIE` poly_lie
168 final_binds = poly_binds `ThenBinds`
169 SingleBind (NonRecBind inst_mbinds) `ThenBinds`
172 returnTc (prag_info_fn, (combiner final_binds thing, final_lie, thing_ty))
173 ) `thenTc` \ (_, result) ->
176 binder_names = collectBinders bind
179 tcBindAndSigs binder_names bind sigs prag_info_fn
181 -- If typechecking the binds fails, then return with each
182 -- binder given type (forall a.a), to minimise subsequent
184 newTcTyVar Nothing mkBoxedTypeKind `thenNF_Tc` \ alpha_tv ->
186 forall_a_a = mkForAllTy alpha_tv (mkTyVarTy alpha_tv)
187 poly_ids = [ mkUserId name forall_a_a (prag_info_fn name)
188 | name <- binder_names]
190 returnTc (EmptyBinds, emptyLIE, poly_ids)
193 -- Create a new identifier for each binder, with each being given
194 -- a type-variable type.
195 newMonoIds binder_names kind (\ mono_ids ->
196 tcTySigs sigs `thenTc` \ sig_info ->
197 tc_bind bind `thenTc` \ (bind', lie) ->
198 returnTc (mono_ids, bind', lie, sig_info)
200 `thenTc` \ (mono_ids, bind', lie, sig_info) ->
202 -- Notice that genBinds gets the old (non-extended) environment
203 genBinds binder_names mono_ids bind' lie sig_info prag_info_fn
206 NonRecBind _ -> mkBoxedTypeKind -- Recursive, so no unboxed types
207 RecBind _ -> mkTypeKind -- Non-recursive, so we permit unboxed types
211 tc_bind :: RenamedBind -> TcM s (TcBind s, LIE s)
213 tc_bind (NonRecBind mono_binds)
214 = tcMonoBinds mono_binds `thenTc` \ (mono_binds2, lie) ->
215 returnTc (NonRecBind mono_binds2, lie)
217 tc_bind (RecBind mono_binds)
218 = tcMonoBinds mono_binds `thenTc` \ (mono_binds2, lie) ->
219 returnTc (RecBind mono_binds2, lie)
223 tcMonoBinds :: RenamedMonoBinds -> TcM s (TcMonoBinds s, LIE s)
225 tcMonoBinds EmptyMonoBinds = returnTc (EmptyMonoBinds, emptyLIE)
227 tcMonoBinds (AndMonoBinds mb1 mb2)
228 = tcMonoBinds mb1 `thenTc` \ (mb1a, lie1) ->
229 tcMonoBinds mb2 `thenTc` \ (mb2a, lie2) ->
230 returnTc (AndMonoBinds mb1a mb2a, lie1 `plusLIE` lie2)
232 tcMonoBinds bind@(PatMonoBind pat grhss_and_binds locn)
236 tcPat pat `thenTc` \ (pat2, lie_pat, pat_ty) ->
238 -- BINDINGS AND GRHSS
239 tcGRHSsAndBinds grhss_and_binds `thenTc` \ (grhss_and_binds2, lie, grhss_ty) ->
241 -- Unify the two sides
242 tcAddErrCtxt (patMonoBindsCtxt bind) $
243 unifyTauTy pat_ty grhss_ty `thenTc_`
246 returnTc (PatMonoBind pat2 grhss_and_binds2 locn,
249 tcMonoBinds (FunMonoBind name matches locn)
251 tcLookupLocalValueOK "tcMonoBinds" name `thenNF_Tc` \ id ->
252 tcMatchesFun name (idType id) matches `thenTc` \ (matches', lie) ->
253 returnTc (FunMonoBind (TcId id) matches' locn, lie)
256 %************************************************************************
258 \subsection{Signatures}
260 %************************************************************************
262 @tcSigs@ checks the signatures for validity, and returns a list of
263 {\em freshly-instantiated} signatures. That is, the types are already
264 split up, and have fresh type variables installed. All non-type-signature
265 "RenamedSigs" are ignored.
268 tcTySigs :: [RenamedSig] -> TcM s [TcSigInfo s]
270 tcTySigs (Sig v ty _ src_loc : other_sigs)
271 = tcAddSrcLoc src_loc (
272 tcPolyType ty `thenTc` \ sigma_ty ->
273 tcInstType [] sigma_ty `thenNF_Tc` \ tc_sigma_ty ->
275 (tyvars, theta, tau_ty) = splitSigmaTy tc_sigma_ty
277 tcLookupLocalValueOK "tcSig1" v `thenNF_Tc` \ val ->
278 unifyTauTy (idType val) tau_ty `thenTc_`
279 returnTc (TySigInfo val tyvars theta tau_ty src_loc)
280 ) `thenTc` \ sig_info1 ->
282 tcTySigs other_sigs `thenTc` \ sig_infos ->
283 returnTc (sig_info1 : sig_infos)
285 tcTySigs (other : sigs) = tcTySigs sigs
286 tcTySigs [] = returnTc []
290 %************************************************************************
292 \subsection{SPECIALIZE pragmas}
294 %************************************************************************
297 @tcPragmaSigs@ munches up the "signatures" that arise through *user*
298 pragmas. It is convenient for them to appear in the @[RenamedSig]@
299 part of a binding because then the same machinery can be used for
300 moving them into place as is done for type signatures.
303 tcPragmaSigs :: [RenamedSig] -- The pragma signatures
304 -> TcM s (Name -> PragmaInfo, -- Maps name to the appropriate PragmaInfo
308 tcPragmaSigs sigs = returnTc ( \name -> NoPragmaInfo, EmptyBinds, emptyLIE )
312 = mapAndUnzip3Tc tcPragmaSig sigs `thenTc` \ (names_w_id_infos, binds, lies) ->
314 name_to_info name = foldr ($) noIdInfo
315 [info_fn | (n,info_fn) <- names_w_id_infos, n==name]
317 returnTc (name_to_info,
318 foldr ThenBinds EmptyBinds binds,
319 foldr plusLIE emptyLIE lies)
322 Here are the easy cases for tcPragmaSigs
325 tcPragmaSig (DeforestSig name loc)
326 = returnTc ((name, addInfo DoDeforest),EmptyBinds,emptyLIE)
327 tcPragmaSig (InlineSig name loc)
328 = returnTc ((name, addInfo_UF (iWantToBeINLINEd UnfoldAlways)), EmptyBinds, emptyLIE)
329 tcPragmaSig (MagicUnfoldingSig name string loc)
330 = returnTc ((name, addInfo_UF (mkMagicUnfolding string)), EmptyBinds, emptyLIE)
333 The interesting case is for SPECIALISE pragmas. There are two forms.
334 Here's the first form:
336 f :: Ord a => [a] -> b -> b
337 {-# SPECIALIZE f :: [Int] -> b -> b #-}
340 For this we generate:
342 f* = /\ b -> let d1 = ...
346 where f* is a SpecPragmaId. The **sole** purpose of SpecPragmaIds is to
347 retain a right-hand-side that the simplifier will otherwise discard as
348 dead code... the simplifier has a flag that tells it not to discard
349 SpecPragmaId bindings.
351 In this case the f* retains a call-instance of the overloaded
352 function, f, (including appropriate dictionaries) so that the
353 specialiser will subsequently discover that there's a call of @f@ at
354 Int, and will create a specialisation for @f@. After that, the
355 binding for @f*@ can be discarded.
357 The second form is this:
359 f :: Ord a => [a] -> b -> b
360 {-# SPECIALIZE f :: [Int] -> b -> b = g #-}
363 Here @g@ is specified as a function that implements the specialised
364 version of @f@. Suppose that g has type (a->b->b); that is, g's type
365 is more general than that required. For this we generate
367 f@Int = /\b -> g Int b
371 Here @f@@Int@ is a SpecId, the specialised version of @f@. It inherits
372 f's export status etc. @f*@ is a SpecPragmaId, as before, which just serves
373 to prevent @f@@Int@ from being discarded prematurely. After specialisation,
374 if @f@@Int@ is going to be used at all it will be used explicitly, so the simplifier can
375 discard the f* binding.
377 Actually, there is really only point in giving a SPECIALISE pragma on exported things,
378 and the simplifer won't discard SpecIds for exporte things anyway, so maybe this is
382 tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc)
383 = tcAddSrcLoc src_loc $
384 tcAddErrCtxt (valSpecSigCtxt name spec_ty) $
386 -- Get and instantiate its alleged specialised type
387 tcPolyType poly_ty `thenTc` \ sig_sigma ->
388 tcInstType [] (idType sig_sigma) `thenNF_Tc` \ sig_ty ->
390 (sig_tyvars, sig_theta, sig_tau) = splitSigmaTy sig_ty
391 origin = ValSpecOrigin name
394 -- Check that the SPECIALIZE pragma had an empty context
395 checkTc (null sig_theta)
396 (panic "SPECIALIZE non-empty context (ToDo: msg)") `thenTc_`
398 -- Get and instantiate the type of the id mentioned
399 tcLookupLocalValueOK "tcPragmaSig" name `thenNF_Tc` \ main_id ->
400 tcInstType [] (idType main_id) `thenNF_Tc` \ main_ty ->
402 (main_tyvars, main_rho) = splitForAllTy main_ty
403 (main_theta,main_tau) = splitRhoTy main_rho
404 main_arg_tys = map mkTyVarTy main_tyvars
407 -- Check that the specialised type is indeed an instance of
408 -- the type of the main function.
409 unifyTauTy sig_tau main_tau `thenTc_`
410 checkSigTyVars sig_tyvars sig_tau main_tau `thenTc_`
412 -- Check that the type variables of the polymorphic function are
413 -- either left polymorphic, or instantiate to ground type.
414 -- Also check that the overloaded type variables are instantiated to
415 -- ground type; or equivalently that all dictionaries have ground type
416 mapTc zonkTcType main_arg_tys `thenNF_Tc` \ main_arg_tys' ->
417 zonkTcThetaType main_theta `thenNF_Tc` \ main_theta' ->
418 tcAddErrCtxt (specGroundnessCtxt main_arg_tys')
419 (checkTc (all isGroundOrTyVarTy main_arg_tys')) `thenTc_`
420 tcAddErrCtxt (specContextGroundnessCtxt main_theta')
421 (checkTc (and [isGroundTy ty | (_,ty) <- theta'])) `thenTc_`
423 -- Build the SpecPragmaId; it is the thing that makes sure we
424 -- don't prematurely dead-code-eliminate the binding we are really interested in.
425 newSpecPragmaId name sig_ty `thenNF_Tc` \ spec_pragma_id ->
427 -- Build a suitable binding; depending on whether we were given
428 -- a value (Maybe Name) to be used as the specialisation.
430 Nothing -> -- No implementation function specified
432 -- Make a Method inst for the occurrence of the overloaded function
433 newMethodWithGivenTy (OccurrenceOf name)
434 (TcId main_id) main_arg_tys main_rho `thenNF_Tc` \ (lie, meth_id) ->
437 pseudo_bind = VarMonoBind spec_pragma_id pseudo_rhs
438 pseudo_rhs = mkHsTyLam sig_tyvars (HsVar (TcId meth_id))
440 returnTc (pseudo_bind, lie, \ info -> info)
442 Just spec_name -> -- Use spec_name as the specialisation value ...
444 -- Type check a simple occurrence of the specialised Id
445 tcId spec_name `thenTc` \ (spec_body, spec_lie, spec_tau) ->
447 -- Check that it has the correct type, and doesn't constrain the
448 -- signature variables at all
449 unifyTauTy sig_tau spec_tau `thenTc_`
450 checkSigTyVars sig_tyvars sig_tau spec_tau `thenTc_`
452 -- Make a local SpecId to bind to applied spec_id
453 newSpecId main_id main_arg_tys sig_ty `thenNF_Tc` \ local_spec_id ->
456 spec_rhs = mkHsTyLam sig_tyvars spec_body
457 spec_binds = VarMonoBind local_spec_id spec_rhs
459 VarMonoBind spec_pragma_id (HsVar (TcId local_spec_id))
460 spec_info = SpecInfo spec_tys (length main_theta) local_spec_id
462 returnTc ((name, addInfo spec_info), spec_binds, spec_lie)
467 Error contexts and messages
468 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
470 patMonoBindsCtxt bind sty
471 = ppHang (ppPStr SLIT("In a pattern binding:")) 4 (ppr sty bind)
473 --------------------------------------------
474 specContextGroundnessCtxt -- err_ctxt dicts sty
475 = panic "specContextGroundnessCtxt"
478 ppSep [ppBesides [ppStr "In the SPECIALIZE pragma for `", ppr sty name, ppStr "'"],
479 ppBesides [ppStr " specialised to the type `", ppr sty spec_ty, ppStr "'"],
481 ppStr "... not all overloaded type variables were instantiated",
482 ppStr "to ground types:"])
483 4 (ppAboves [ppCat [ppr sty c, ppr sty t]
484 | (c,t) <- map getDictClassAndType dicts])
486 (name, spec_ty, locn, pp_spec_id)
488 ValSpecSigCtxt n ty loc -> (n, ty, loc, \ x -> ppNil)
489 ValSpecSpecIdCtxt n ty spec loc ->
491 \ sty -> ppBesides [ppStr "... type of explicit id `", ppr sty spec, ppStr "'"])
494 -----------------------------------------------
496 = panic "specGroundnessCtxt"
499 valSpecSigCtxt v ty sty
500 = ppHang (ppPStr SLIT("In a SPECIALIZE pragma for a value:"))
501 4 (ppSep [ppBeside (pprNonOp sty v) (ppPStr SLIT(" ::")),