+ f = /\a -> \d::Eq a -> let f' = f a d
+ in
+ \ys:[a] -> ...f'...
+
+Notice the the stupid construction of (f a d), which is of course
+identical to the function we're executing. In this case, the
+polymorphic recursion isn't being used (but that's a very common case).
+We'd prefer
+
+ f = /\a -> \d::Eq a -> letrec
+ fm = \ys:[a] -> ...fm...
+ in
+ fm
+
+This can lead to a massive space leak, from the following top-level defn
+(post-typechecking)
+
+ ff :: [Int] -> [Int]
+ ff = f Int dEqInt
+
+Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but
+f' is another thunk which evaluates to the same thing... and you end
+up with a chain of identical values all hung onto by the CAF ff.
+
+ ff = f Int dEqInt
+
+ = let f' = f Int dEqInt in \ys. ...f'...
+
+ = let f' = let f' = f Int dEqInt in \ys. ...f'...
+ in \ys. ...f'...
+
+Etc.
+Solution: when typechecking the RHSs we always have in hand the
+*monomorphic* Ids for each binding. So we just need to make sure that
+if (Method f a d) shows up in the constraints emerging from (...f...)
+we just use the monomorphic Id. We achieve this by adding monomorphic Ids
+to the "givens" when simplifying constraints. That's what the "lies_avail"
+is doing.
+
+
+%************************************************************************
+%* *
+\subsection{getTyVarsToGen}
+%* *
+%************************************************************************
+
+\begin{code}
+generalise binder_names mbind tau_tvs lie_req sigs
+ | not is_unrestricted -- RESTRICTED CASE
+ = -- Check signature contexts are empty
+ checkTc (all is_mono_sig sigs)
+ (restrictedBindCtxtErr binder_names) `thenTc_`
+
+ -- Now simplify with exactly that set of tyvars
+ -- We have to squash those Methods
+ tcSimplifyRestricted doc tau_tvs lie_req `thenTc` \ (qtvs, lie_free, binds) ->
+
+ -- Check that signature type variables are OK
+ checkSigsTyVars sigs `thenTc_`
+
+ returnTc (qtvs, lie_free, binds, [])
+
+ | null sigs -- UNRESTRICTED CASE, NO TYPE SIGS
+ = tcSimplifyInfer doc tau_tvs lie_req
+
+ | otherwise -- UNRESTRICTED CASE, WITH TYPE SIGS
+ = -- CHECKING CASE: Unrestricted group, there are type signatures
+ -- Check signature contexts are empty
+ checkSigsCtxts sigs `thenTc` \ (sig_avails, sig_dicts) ->
+
+ -- Check that the needed dicts can be
+ -- expressed in terms of the signature ones
+ tcSimplifyInferCheck doc tau_tvs sig_avails lie_req `thenTc` \ (forall_tvs, lie_free, dict_binds) ->
+
+ -- Check that signature type variables are OK
+ checkSigsTyVars sigs `thenTc_`
+
+ returnTc (forall_tvs, lie_free, dict_binds, sig_dicts)
+
+ where
+ is_unrestricted | opt_NoMonomorphismRestriction = True
+ | otherwise = isUnRestrictedGroup tysig_names mbind
+
+ tysig_names = [name | (TySigInfo name _ _ _ _ _ _ _) <- sigs]
+ is_mono_sig (TySigInfo _ _ _ theta _ _ _ _) = null theta
+
+ doc = ptext SLIT("type signature(s) for") <+> pprBinders binder_names
+
+-----------------------
+ -- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE UNIFIABLE
+ -- The type signatures on a mutually-recursive group of definitions
+ -- must all have the same context (or none).
+ --
+ -- We unify them because, with polymorphic recursion, their types
+ -- might not otherwise be related. This is a rather subtle issue.
+ -- ToDo: amplify
+checkSigsCtxts sigs@(TySigInfo _ id1 sig_tvs theta1 _ _ _ src_loc : other_sigs)
+ = tcAddSrcLoc src_loc $
+ mapTc_ check_one other_sigs `thenTc_`
+ if null theta1 then
+ returnTc ([], []) -- Non-overloaded type signatures
+ else
+ newDicts SignatureOrigin theta1 `thenNF_Tc` \ sig_dicts ->
+ let
+ -- The "sig_avails" is the stuff available. We get that from
+ -- the context of the type signature, BUT ALSO the lie_avail
+ -- so that polymorphic recursion works right (see comments at end of fn)
+ sig_avails = sig_dicts ++ sig_meths
+ in
+ returnTc (sig_avails, map instToId sig_dicts)
+ where
+ sig1_dict_tys = map mkPredTy theta1
+ n_sig1_theta = length theta1
+ sig_meths = concat [insts | TySigInfo _ _ _ _ _ _ insts _ <- sigs]
+
+ check_one sig@(TySigInfo _ id _ theta _ _ _ src_loc)
+ = tcAddErrCtxt (sigContextsCtxt id1 id) $
+ checkTc (length theta == n_sig1_theta) sigContextsErr `thenTc_`
+ unifyTauTyLists sig1_dict_tys (map mkPredTy theta)
+
+checkSigsTyVars sigs = mapTc_ check_one sigs
+ where
+ check_one (TySigInfo _ id sig_tyvars sig_theta sig_tau _ _ src_loc)
+ = tcAddSrcLoc src_loc $
+ tcAddErrCtxtM (sigCtxt (sig_msg id) sig_tyvars sig_theta sig_tau) $
+ checkSigTyVars sig_tyvars (idFreeTyVars id)
+
+ sig_msg id = ptext SLIT("When checking the type signature for") <+> quotes (ppr id)
projects / ghc-hetmet.git / blobdiff