2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[TcBinds]{TcBinds}
7 #include "HsVersions.h"
10 tcTopBindsAndThen, tcLocalBindsAndThen,
14 --IMPORT_Trace -- ToDo:rm (debugging)
16 import TcMonad -- typechecking monad machinery
17 import TcMonadFns ( newLocalsWithOpenTyVarTys,
18 newLocalsWithPolyTyVarTys,
19 newSpecPragmaId, newSpecId,
20 applyTcSubstAndCollectTyVars
22 import AbsSyn -- the stuff being typechecked
24 import AbsUniType ( isTyVarTy, isGroundTy, isUnboxedDataType,
25 isGroundOrTyVarTy, extractTyVarsFromTy,
28 import BackSubst ( applyTcSubstToBinds )
30 import Errors ( topLevelUnboxedDeclErr, specGroundnessErr,
31 specCtxtGroundnessErr, Error(..), UnifyErrContext(..)
33 import GenSpecEtc ( checkSigTyVars, genBinds, SignatureInfo(..) )
34 import Id ( getIdUniType, mkInstId )
35 import IdInfo ( SpecInfo(..) )
37 import LIE ( nullLIE, mkLIE, plusLIE, LIE )
38 import Maybes ( assocMaybe, catMaybes, Maybe(..) )
39 import Spec ( specTy )
40 import TVE ( nullTVE, TVE(..), UniqFM )
41 import TcMonoBnds ( tcMonoBinds )
42 import TcPolyType ( tcPolyType )
43 import TcSimplify ( bindInstsOfLocalFuns )
44 import Unify ( unifyTauTy )
45 import UniqFM ( emptyUFM ) -- profiling, pragmas only
49 %************************************************************************
51 \subsection{Type-checking top-level bindings}
53 %************************************************************************
55 @tcBindsAndThen@ takes a boolean which indicates whether the binding
56 group is at top level or not. The difference from inner bindings is
60 we zero the substitution before each group
62 we back-substitute after each group.
64 We still return an LIE, but it is sure to contain nothing but constant
65 dictionaries, which we resolve at the module level.
67 @tcTopBinds@ returns an LVE, not, as you might expect, a GVE. Why?
68 Because the monomorphism restriction means that is might return some
69 monomorphic things, with free type variables. Hence it must be an LVE.
71 The LIE returned by @tcTopBinds@ may constrain some type variables,
72 but they are guaranteed to be a subset of those free in the
73 corresponding returned LVE.
75 %************************************************************************
77 \subsection{Type-checking bindings}
79 %************************************************************************
81 @tcBindsAndThen@ typechecks a @Binds@. The "and then" part is because
82 it needs to know something about the {\em usage} of the things bound,
83 so that it can create specialisations of them. So @tcBindsAndThen@
84 takes a function which, given an extended environment, E, typechecks
85 the scope of the bindings returning a typechecked thing and (most
86 important) an LIE. It is this LIE which is then used as the basis for
87 specialising the things bound.
89 @tcBindsAndThen@ also takes a "combiner" which glues together the
90 bindings and the "thing" to make a new "thing".
92 The real work is done by @tcBindAndThen@.
94 Recursive and non-recursive binds are handled in essentially the same
95 way: because of uniques there are no scoping issues left. The only
96 difference is that non-recursive bindings can bind primitive values.
98 Even for non-recursive binding groups we add typings for each binder
99 to the LVE for the following reason. When each individual binding is
100 checked the type of its LHS is unified with that of its RHS; and
101 type-checking the LHS of course requires that the binder is in scope.
107 -> (TypecheckedBinds -> thing -> thing) -- Combinator
109 -> (E -> TcM (thing, LIE, thing_ty))
110 -> TcM (thing, LIE, thing_ty)
112 tcBindsAndThen top_level e combiner EmptyBinds do_next
113 = do_next e `thenTc` \ (thing, lie, thing_ty) ->
114 returnTc (combiner EmptyBinds thing, lie, thing_ty)
116 tcBindsAndThen top_level e combiner (SingleBind bind) do_next
117 = tcBindAndThen top_level e combiner bind [] do_next
119 tcBindsAndThen top_level e combiner (BindWith bind sigs) do_next
120 = tcBindAndThen top_level e combiner bind sigs do_next
122 tcBindsAndThen top_level e combiner (ThenBinds binds1 binds2) do_next
123 = tcBindsAndThen top_level e combiner binds1 new_after
125 -- new_after :: E -> TcM (thing, LIE, thing_ty)
126 -- Can't write this signature, cos it's monomorphic in thing and
128 new_after e = tcBindsAndThen top_level e combiner binds2 do_next
131 Simple wrappers for export:
135 -> (TypecheckedBinds -> thing -> thing) -- Combinator
137 -> (E -> TcM (thing, LIE, anything))
138 -> TcM (thing, LIE, anything)
140 tcTopBindsAndThen e combiner binds do_next
141 = tcBindsAndThen True e combiner binds do_next
145 -> (TypecheckedBinds -> thing -> thing) -- Combinator
147 -> (E -> TcM (thing, LIE, thing_ty))
148 -> TcM (thing, LIE, thing_ty)
150 tcLocalBindsAndThen e combiner binds do_next
151 = tcBindsAndThen False e combiner binds do_next
154 An aside. The original version of @tcBindsAndThen@ which lacks a
155 combiner function, appears below. Though it is perfectly well
156 behaved, it cannot be typed by Haskell, because the recursive call is
157 at a different type to the definition itself. There aren't too many
158 examples of this, which is why I thought it worth preserving! [SLPJ]
162 :: Bool -> E -> RenamedBinds
163 -> (E -> TcM (thing, LIE, thing_ty))
164 -> TcM ((TypecheckedBinds, thing), LIE, thing_ty)
166 tcBindsAndThen top_level e EmptyBinds do_next
167 = do_next e `thenTc` \ (thing, lie, thing_ty) ->
168 returnTc ((EmptyBinds, thing), lie, thing_ty)
170 tcBindsAndThen top_level e (SingleBind bind) do_next
171 = tcBindAndThen top_level e bind [] do_next
173 tcBindsAndThen top_level e (BindWith bind sigs) do_next
174 = tcBindAndThen top_level e bind sigs do_next
176 tcBindsAndThen top_level e (ThenBinds binds1 binds2) do_next
177 = tcBindsAndThen top_level e binds1 new_after
178 `thenTc` \ ((binds1', (binds2', thing')), lie1, thing_ty) ->
180 returnTc ((binds1' `ThenBinds` binds2', thing'), lie1, thing_ty)
183 -- new_after :: E -> TcM ((TypecheckedBinds, thing), LIE, thing_ty)
184 -- Can't write this signature, cos it's monomorphic in thing and thing_ty
185 new_after e = tcBindsAndThen top_level e binds2 do_next
188 %************************************************************************
192 %************************************************************************
196 :: Bool -- At top level
198 -> (TypecheckedBinds -> thing -> thing) -- Combinator
199 -> RenamedBind -- The Bind to typecheck
200 -> [RenamedSig] -- ...and its signatures
201 -> (E -> TcM (thing, LIE, thing_ty)) -- Thing to type check in
203 -> TcM (thing, LIE, thing_ty) -- Results, incl the
205 tcBindAndThen top_level e combiner bind sigs do_next
206 = -- Deal with the bind
207 tcBind top_level e bind sigs `thenTc` \ (poly_binds, poly_lie, poly_lve) ->
209 -- Now do whatever happens next, in the augmented envt
210 do_next (growE_LVE e poly_lve) `thenTc` \ (thing, thing_lie, thing_ty) ->
212 bound_ids = map snd poly_lve
214 -- Create specialisations
215 specialiseBinds bound_ids thing_lie poly_binds poly_lie
216 `thenNF_Tc` \ (final_binds, final_lie) ->
218 returnTc (combiner final_binds thing, final_lie, thing_ty)
223 -> RenamedBind -> [RenamedSig]
224 -> TcM (TypecheckedBinds, LIE, LVE) -- LIE is a fixed point of substitution
226 tcBind False e bind sigs -- Not top level
227 = tcBind_help False e bind sigs
229 tcBind True e bind sigs -- Top level!
230 = pruneSubstTc (tvOfE e) (
233 tcBind_help True e bind sigs `thenTc` \ (new_binds, lie, lve) ->
235 {- Top-level unboxed values are now allowed
236 They will be lifted by the Desugarer (see CoreLift.lhs)
238 -- CHECK FOR PRIMITIVE TOP-LEVEL BINDS
239 listTc [ checkTc (isUnboxedDataType (getIdUniType id))
240 (topLevelUnboxedDeclErr id (getSrcLoc id))
241 | (_,id) <- lve ] `thenTc_`
244 -- Back-substitute over the binds, since we are about to discard
245 -- a good chunk of the substitution.
246 applyTcSubstToBinds new_binds `thenNF_Tc` \ final_binds ->
248 -- The lie is already a fixed point of the substitution; it just turns out
249 -- that almost always this happens automatically, and so we made it part of
250 -- the specification of genBinds.
251 returnTc (final_binds, lie, lve)
256 tcBind_help top_level e bind sigs
257 = -- Create an LVE binding each identifier to an appropriate type variable
258 new_locals binders `thenNF_Tc` \ bound_ids ->
259 let lve = binders `zip` bound_ids in
261 -- Now deal with type signatures, if any
262 tcSigs e lve sigs `thenTc` \ sig_info ->
264 -- Check the bindings: this is the point at which we can use
265 -- error recovery. If checking the bind fails we just
266 -- return the empty bindings. The variables will still be in
267 -- scope, but bound to completely free type variables, which
268 -- is just what we want to minimise subsequent error messages.
269 recoverTc (NonRecBind EmptyMonoBinds, nullLIE)
270 (tc_bind (growE_LVE e lve) bind) `thenNF_Tc` \ (bind', lie) ->
272 -- Notice that genBinds gets the old (non-extended) environment
273 genBinds top_level e bind' lie lve sig_info `thenTc` \ (binds', lie, lve) ->
275 -- Add bindings corresponding to SPECIALIZE pragmas in the code
276 mapAndUnzipTc (doSpecPragma e (assoc "doSpecPragma" lve))
277 (get_spec_pragmas sig_info)
278 `thenTc` \ (spec_binds_s, spec_lie_s) ->
280 returnTc (binds' `ThenBinds` (SingleBind (NonRecBind (
281 foldr AndMonoBinds EmptyMonoBinds spec_binds_s))),
282 lie `plusLIE` (foldr plusLIE nullLIE spec_lie_s),
285 binders = collectBinders bind
289 NonRecBind _ -> -- Recursive, so no unboxed types
290 newLocalsWithOpenTyVarTys binders
292 RecBind _ -> -- Non-recursive, so we permit unboxed types
293 newLocalsWithPolyTyVarTys binders
295 get_spec_pragmas sig_info
296 = catMaybes (map get_pragma_maybe sig_info)
298 get_pragma_maybe s@(ValSpecInfo _ _ _ _) = Just s
299 get_pragma_maybe _ = Nothing
303 f :: Ord a => [a] -> b -> b
304 {-# SPECIALIZE f :: [Int] -> b -> b #-}
308 f@Int = /\ b -> let d1 = ...
312 h :: Ord a => [a] -> b -> b
313 {-# SPECIALIZE h :: [Int] -> b -> b #-}
315 spec_h = /\b -> h [Int] b dListOfInt
316 ^^^^^^^^^^^^^^^^^^^^ This bit created by specId
323 -> TcM (TypecheckedMonoBinds, LIE)
325 doSpecPragma e name_to_id (ValSpecInfo name spec_ty using src_loc)
327 main_id = name_to_id name -- Get the parent Id
329 main_id_ty = getIdUniType main_id
330 main_id_free_tyvars = extractTyVarsFromTy main_id_ty
331 origin = ValSpecOrigin name src_loc
332 err_ctxt = ValSpecSigCtxt name spec_ty src_loc
334 addSrcLocTc src_loc (
335 specTy origin spec_ty `thenNF_Tc` \ (spec_tyvars, spec_dicts, spec_tau) ->
337 -- Check that the SPECIALIZE pragma had an empty context
338 checkTc (not (null spec_dicts))
339 (panic "SPECIALIZE non-empty context (ToDo: msg)") `thenTc_`
341 -- Make an instance of this id
342 specTy origin main_id_ty `thenNF_Tc` \ (main_tyvars, main_dicts, main_tau) ->
344 -- Check that the specialised type is indeed an instance of
345 -- the inferred type.
346 -- The unification should leave all type vars which are
347 -- currently free in the environment still free, and likewise
348 -- the signature type vars.
349 -- The only way type vars free in the envt could possibly be affected
350 -- is if main_id_ty has free type variables. So we just extract them,
351 -- and check that they are not constrained in any way by the unification.
352 applyTcSubstAndCollectTyVars main_id_free_tyvars `thenNF_Tc` \ free_tyvars' ->
353 unifyTauTy spec_tau main_tau err_ctxt `thenTc_`
354 checkSigTyVars [] (spec_tyvars ++ free_tyvars')
355 spec_tau main_tau err_ctxt `thenTc_`
357 -- Check that the type variables of the polymorphic function are
358 -- either left polymorphic, or instantiate to ground type.
359 -- Also check that the overloaded type variables are instantiated to
360 -- ground type; or equivalently that all dictionaries have ground type
361 applyTcSubstToTyVars main_tyvars `thenNF_Tc` \ main_arg_tys ->
362 applyTcSubstToInsts main_dicts `thenNF_Tc` \ main_dicts' ->
364 checkTc (not (all isGroundOrTyVarTy main_arg_tys))
365 (specGroundnessErr err_ctxt main_arg_tys)
368 checkTc (not (and [isGroundTy ty | (_,ty) <- map getDictClassAndType main_dicts']))
369 (specCtxtGroundnessErr err_ctxt main_dicts')
372 -- Build a suitable binding; depending on whether we were given
373 -- a value (Maybe Name) to be used as the specialisation.
377 -- Make a specPragmaId to which to bind the new call-instance
378 newSpecPragmaId name spec_ty Nothing
379 `thenNF_Tc` \ pseudo_spec_id ->
381 pseudo_bind = VarMonoBind pseudo_spec_id pseudo_rhs
382 pseudo_rhs = mkTyLam spec_tyvars (mkDictApp (mkTyApp (Var main_id) main_arg_tys)
383 (map mkInstId main_dicts'))
385 returnTc (pseudo_bind, mkLIE main_dicts')
387 Just spec_name -> -- use spec_name as the specialisation value ...
389 spec_id = lookupE_Value e spec_name
390 spec_id_ty = getIdUniType spec_id
392 spec_id_free_tyvars = extractTyVarsFromTy spec_id_ty
393 spec_id_ctxt = ValSpecSpecIdCtxt name spec_ty spec_name src_loc
395 spec_tys = map maybe_ty main_arg_tys
396 maybe_ty ty | isTyVarTy ty = Nothing
397 | otherwise = Just ty
399 -- Make an instance of the spec_id
400 specTy origin spec_id_ty `thenNF_Tc` \ (spec_id_tyvars, spec_id_dicts, spec_id_tau) ->
402 -- Check that the specialised type is indeed an instance of
403 -- the type inferred for spec_id
404 -- The unification should leave all type vars which are
405 -- currently free in the environment still free, and likewise
406 -- the signature type vars.
407 -- The only way type vars free in the envt could possibly be affected
408 -- is if spec_id_ty has free type variables. So we just extract them,
409 -- and check that they are not constrained in any way by the unification.
410 applyTcSubstAndCollectTyVars spec_id_free_tyvars `thenNF_Tc` \ spec_id_free_tyvars' ->
411 unifyTauTy spec_tau spec_id_tau spec_id_ctxt `thenTc_`
412 checkSigTyVars [] (spec_tyvars ++ spec_id_free_tyvars')
413 spec_tau spec_id_tau spec_id_ctxt `thenTc_`
415 -- Check that the type variables of the explicit spec_id are
416 -- either left polymorphic, or instantiate to ground type.
417 -- Also check that the overloaded type variables are instantiated to
418 -- ground type; or equivalently that all dictionaries have ground type
419 applyTcSubstToTyVars spec_id_tyvars `thenNF_Tc` \ spec_id_arg_tys ->
420 applyTcSubstToInsts spec_id_dicts `thenNF_Tc` \ spec_id_dicts' ->
422 checkTc (not (all isGroundOrTyVarTy spec_id_arg_tys))
423 (specGroundnessErr spec_id_ctxt spec_id_arg_tys)
426 checkTc (not (and [isGroundTy ty | (_,ty) <- map getDictClassAndType spec_id_dicts']))
427 (specCtxtGroundnessErr spec_id_ctxt spec_id_dicts')
430 -- Make a local SpecId to bind to applied spec_id
431 newSpecId main_id spec_tys spec_ty `thenNF_Tc` \ local_spec_id ->
433 -- Make a specPragmaId id with a spec_info for local_spec_id
434 -- This is bound to local_spec_id
435 -- The SpecInfo will be extracted by the specialiser and
436 -- used to create a call instance for main_id (which is
437 -- extracted from the spec_id)
438 -- NB: the pseudo_local_id must stay in the scope of main_id !!!
440 spec_info = SpecInfo spec_tys (length main_dicts') local_spec_id
442 newSpecPragmaId name spec_ty (Just spec_info) `thenNF_Tc` \ pseudo_spec_id ->
444 spec_bind = VarMonoBind local_spec_id spec_rhs
445 spec_rhs = mkTyLam spec_tyvars (mkDictApp (mkTyApp (Var spec_id) spec_id_arg_tys)
446 (map mkInstId spec_id_dicts'))
447 pseudo_bind = VarMonoBind pseudo_spec_id (Var local_spec_id)
449 returnTc (spec_bind `AndMonoBinds` pseudo_bind, mkLIE spec_id_dicts')
456 -> TcM (TypecheckedBind, LIE)
458 tc_bind e (NonRecBind mono_binds)
459 = tcMonoBinds e mono_binds `thenTc` \ (mono_binds2, lie) ->
460 returnTc (NonRecBind mono_binds2, lie)
462 tc_bind e (RecBind mono_binds)
463 = tcMonoBinds e mono_binds `thenTc` \ (mono_binds2, lie) ->
464 returnTc (RecBind mono_binds2, lie)
469 :: [Id] -- Ids bound in this group
470 -> LIE -- LIE of scope of these bindings
473 -> NF_TcM (TypecheckedBinds, LIE)
475 specialiseBinds bound_ids lie_of_scope poly_binds poly_lie
476 = bindInstsOfLocalFuns lie_of_scope bound_ids
477 `thenNF_Tc` \ (lie2, inst_mbinds) ->
479 returnNF_Tc (poly_binds `ThenBinds` (SingleBind (NonRecBind inst_mbinds)),
480 lie2 `plusLIE` poly_lie)
483 %************************************************************************
485 \subsection{Signatures}
487 %************************************************************************
489 @tcSigs@ checks the signatures for validity, and returns a list of
490 {\em freshly-instantiated} signatures. That is, the types are already
491 split up, and have fresh type variables (not @TyVarTemplate@s)
497 -> TcM [SignatureInfo]
499 tcSigs e lve [] = returnTc []
502 = tc_sig s `thenTc` \ sig_info1 ->
503 tcSigs e lve ss `thenTc` \ sig_info2 ->
504 returnTc (sig_info1 : sig_info2)
506 tc_sig (Sig v ty _ src_loc) -- no interesting pragmas on non-iface sigs
507 = addSrcLocTc src_loc (
510 (tcPolyType (getE_CE e) (getE_TCE e) nullTVE ty) `thenTc` \ sigma_ty ->
512 let val = assoc "tcSigs" lve v in
513 -- (The renamer/dependency-analyser should have ensured
514 -- that there are only signatures for which there is a
515 -- corresponding binding.)
517 -- Instantiate the type, and unify with the type variable
519 specTy SignatureOrigin sigma_ty `thenNF_Tc` \ (tyvars, dicts, tau_ty) ->
520 unifyTauTy (getIdUniType val) tau_ty
521 (panic "ToDo: unifyTauTy(tcSigs)") `thenTc_`
523 returnTc (TySigInfo val tyvars dicts tau_ty src_loc)
526 tc_sig (SpecSig v ty using src_loc)
527 = addSrcLocTc src_loc (
530 (tcPolyType (getE_CE e) (getE_TCE e) nullTVE ty) `thenTc` \ sigma_ty ->
532 returnTc (ValSpecInfo v sigma_ty using src_loc)
535 tc_sig (InlineSig v guide locn)
536 = returnTc (ValInlineInfo v guide locn)
538 tc_sig (DeforestSig v locn)
539 = returnTc (ValDeforestInfo v locn)
541 tc_sig (MagicUnfoldingSig v str locn)
542 = returnTc (ValMagicUnfoldingInfo v str locn)