%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcBinds]{TcBinds}
\begin{code}
-#include "HsVersions.h"
-
-module TcBinds (
- tcTopBindsAndThen, tcLocalBindsAndThen,
- tcSigs, doSpecPragma
- ) where
+module TcBinds ( tcBindsAndThen, tcTopBinds, tcMonoBinds, tcSpecSigs ) where
---IMPORT_Trace -- ToDo:rm (debugging)
+#include "HsVersions.h"
-import TcMonad -- typechecking monad machinery
-import TcMonadFns ( newLocalsWithOpenTyVarTys,
- newLocalsWithPolyTyVarTys,
- newSpecPragmaId, newSpecId,
- applyTcSubstAndCollectTyVars
- )
-import AbsSyn -- the stuff being typechecked
+import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
+import {-# SOURCE #-} TcExpr ( tcCheckSigma, tcCheckRho )
-import AbsUniType ( isTyVarTy, isGroundTy, isUnboxedDataType,
- isGroundOrTyVarTy, extractTyVarsFromTy,
- UniType
+import CmdLineOpts ( DynFlag(Opt_NoMonomorphismRestriction) )
+import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..),
+ Match(..), mkMonoBind,
+ collectMonoBinders, andMonoBinds,
+ collectSigTysFromMonoBinds
)
-import BackSubst ( applyTcSubstToBinds )
-import E
-import Errors ( topLevelUnboxedDeclErr, specGroundnessErr,
- specCtxtGroundnessErr, Error(..), UnifyErrContext(..)
+import RnHsSyn ( RenamedHsBinds, RenamedSig, RenamedMonoBinds )
+import TcHsSyn ( TcHsBinds, TcMonoBinds, TcId, zonkId, mkHsLet )
+
+import TcRnMonad
+import Inst ( InstOrigin(..), newDicts, newIPDict, instToId )
+import TcEnv ( tcExtendLocalValEnv, tcExtendLocalValEnv2, newLocalName )
+import TcUnify ( Expected(..), newHole, unifyTauTyLists, checkSigTyVarsWrt, sigCtxt )
+import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted,
+ tcSimplifyToDicts, tcSimplifyIPs )
+import TcMonoType ( tcHsSigType, UserTypeCtxt(..), TcSigInfo(..),
+ tcTySig, maybeSig, tcSigPolyId, tcSigMonoId, tcAddScopedTyVars
)
-import GenSpecEtc ( checkSigTyVars, genBinds, SignatureInfo(..) )
-import Id ( getIdUniType, mkInstId )
-import IdInfo ( SpecInfo(..) )
-import Inst
-import LIE ( nullLIE, mkLIE, plusLIE, LIE )
-import Maybes ( assocMaybe, catMaybes, Maybe(..) )
-import Spec ( specTy )
-import TVE ( nullTVE, TVE(..), UniqFM )
-import TcMonoBnds ( tcMonoBinds )
-import TcPolyType ( tcPolyType )
+import TcPat ( tcPat, tcSubPat, tcMonoPatBndr )
import TcSimplify ( bindInstsOfLocalFuns )
-import Unify ( unifyTauTy )
-import UniqFM ( emptyUFM ) -- profiling, pragmas only
-import Util
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Type-checking top-level bindings}
-%* *
-%************************************************************************
-
-@tcBindsAndThen@ takes a boolean which indicates whether the binding
-group is at top level or not. The difference from inner bindings is
-that
-\begin{enumerate}
-\item
-we zero the substitution before each group
-\item
-we back-substitute after each group.
-\end{enumerate}
-We still return an LIE, but it is sure to contain nothing but constant
-dictionaries, which we resolve at the module level.
+import TcMType ( newTyVar, newTyVarTy, zonkTcTyVarToTyVar )
+import TcType ( TcTyVar, mkTyVarTy, mkForAllTys, mkFunTys, tyVarsOfType,
+ mkPredTy, mkForAllTy, isUnLiftedType,
+ unliftedTypeKind, liftedTypeKind, openTypeKind, eqKind
+ )
-@tcTopBinds@ returns an LVE, not, as you might expect, a GVE. Why?
-Because the monomorphism restriction means that is might return some
-monomorphic things, with free type variables. Hence it must be an LVE.
+import CoreFVs ( idFreeTyVars )
+import Id ( mkLocalId, mkSpecPragmaId, setInlinePragma )
+import Var ( idType, idName )
+import Name ( Name, getSrcLoc )
+import NameSet
+import Var ( tyVarKind )
+import VarSet
+import Bag
+import Util ( isIn, equalLength )
+import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNonRec, isRec,
+ isNotTopLevel, isAlwaysActive )
+import FiniteMap ( listToFM, lookupFM )
+import Outputable
+\end{code}
-The LIE returned by @tcTopBinds@ may constrain some type variables,
-but they are guaranteed to be a subset of those free in the
-corresponding returned LVE.
%************************************************************************
%* *
%* *
%************************************************************************
-@tcBindsAndThen@ typechecks a @Binds@. The "and then" part is because
+@tcBindsAndThen@ typechecks a @HsBinds@. The "and then" part is because
it needs to know something about the {\em usage} of the things bound,
so that it can create specialisations of them. So @tcBindsAndThen@
takes a function which, given an extended environment, E, typechecks
@tcBindsAndThen@ also takes a "combiner" which glues together the
bindings and the "thing" to make a new "thing".
-The real work is done by @tcBindAndThen@.
+The real work is done by @tcBindWithSigsAndThen@.
Recursive and non-recursive binds are handled in essentially the same
way: because of uniques there are no scoping issues left. The only
checked the type of its LHS is unified with that of its RHS; and
type-checking the LHS of course requires that the binder is in scope.
+At the top-level the LIE is sure to contain nothing but constant
+dictionaries, which we resolve at the module level.
+
\begin{code}
-tcBindsAndThen
- :: Bool
- -> E
- -> (TypecheckedBinds -> thing -> thing) -- Combinator
- -> RenamedBinds
- -> (E -> TcM (thing, LIE, thing_ty))
- -> TcM (thing, LIE, thing_ty)
-
-tcBindsAndThen top_level e combiner EmptyBinds do_next
- = do_next e `thenTc` \ (thing, lie, thing_ty) ->
- returnTc (combiner EmptyBinds thing, lie, thing_ty)
-
-tcBindsAndThen top_level e combiner (SingleBind bind) do_next
- = tcBindAndThen top_level e combiner bind [] do_next
-
-tcBindsAndThen top_level e combiner (BindWith bind sigs) do_next
- = tcBindAndThen top_level e combiner bind sigs do_next
-
-tcBindsAndThen top_level e combiner (ThenBinds binds1 binds2) do_next
- = tcBindsAndThen top_level e combiner binds1 new_after
+tcTopBinds :: RenamedHsBinds -> TcM (TcMonoBinds, TcLclEnv)
+ -- Note: returning the TcLclEnv is more than we really
+ -- want. The bit we care about is the local bindings
+ -- and the free type variables thereof
+tcTopBinds binds
+ = tc_binds_and_then TopLevel glue binds $
+ getLclEnv `thenM` \ env ->
+ returnM (EmptyMonoBinds, env)
+ where
+ -- The top level bindings are flattened into a giant
+ -- implicitly-mutually-recursive MonoBinds
+ glue binds1 (binds2, env) = (flatten binds1 `AndMonoBinds` binds2, env)
+ flatten EmptyBinds = EmptyMonoBinds
+ flatten (b1 `ThenBinds` b2) = flatten b1 `AndMonoBinds` flatten b2
+ flatten (MonoBind b _ _) = b
+ -- Can't have a IPBinds at top level
+
+
+tcBindsAndThen
+ :: (TcHsBinds -> thing -> thing) -- Combinator
+ -> RenamedHsBinds
+ -> TcM thing
+ -> TcM thing
+
+tcBindsAndThen = tc_binds_and_then NotTopLevel
+
+tc_binds_and_then top_lvl combiner EmptyBinds do_next
+ = do_next
+tc_binds_and_then top_lvl combiner (MonoBind EmptyMonoBinds sigs is_rec) do_next
+ = do_next
+
+tc_binds_and_then top_lvl combiner (ThenBinds b1 b2) do_next
+ = tc_binds_and_then top_lvl combiner b1 $
+ tc_binds_and_then top_lvl combiner b2 $
+ do_next
+
+tc_binds_and_then top_lvl combiner (IPBinds binds is_with) do_next
+ = getLIE do_next `thenM` \ (result, expr_lie) ->
+ mapAndUnzipM tc_ip_bind binds `thenM` \ (avail_ips, binds') ->
+
+ -- If the binding binds ?x = E, we must now
+ -- discharge any ?x constraints in expr_lie
+ tcSimplifyIPs avail_ips expr_lie `thenM` \ dict_binds ->
+
+ returnM (combiner (IPBinds binds' is_with) $
+ combiner (mkMonoBind Recursive dict_binds) result)
where
- -- new_after :: E -> TcM (thing, LIE, thing_ty)
- -- Can't write this signature, cos it's monomorphic in thing and
- -- thing_ty.
- new_after e = tcBindsAndThen top_level e combiner binds2 do_next
+ -- I wonder if we should do these one at at time
+ -- Consider ?x = 4
+ -- ?y = ?x + 1
+ tc_ip_bind (ip, expr)
+ = newTyVarTy openTypeKind `thenM` \ ty ->
+ getSrcLocM `thenM` \ loc ->
+ newIPDict (IPBind ip) ip ty `thenM` \ (ip', ip_inst) ->
+ tcCheckRho expr ty `thenM` \ expr' ->
+ returnM (ip_inst, (ip', expr'))
+
+tc_binds_and_then top_lvl combiner (MonoBind bind sigs is_rec) do_next
+ = -- BRING ANY SCOPED TYPE VARIABLES INTO SCOPE
+ -- Notice that they scope over
+ -- a) the type signatures in the binding group
+ -- b) the bindings in the group
+ -- c) the scope of the binding group (the "in" part)
+ tcAddScopedTyVars (collectSigTysFromMonoBinds bind) $
+
+ tcBindWithSigs top_lvl bind sigs is_rec `thenM` \ (poly_binds, poly_ids) ->
+
+ case top_lvl of
+ TopLevel -- For the top level don't bother will 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
+ --
+ -- Subtle (and ugly) point: furthermore at top level we
+ -- return the TcLclEnv, which contains the LIE var; we
+ -- don't want to return the wrong one!
+ -> tc_body poly_ids `thenM` \ (prag_binds, thing) ->
+ returnM (combiner (mkMonoBind Recursive (poly_binds `andMonoBinds` prag_binds))
+ thing)
+
+ NotTopLevel -- For nested bindings we must do teh bindInstsOfLocalFuns thing
+ -> getLIE (tc_body poly_ids) `thenM` \ ((prag_binds, thing), lie) ->
+
+ -- Create specialisations of functions bound here
+ bindInstsOfLocalFuns lie poly_ids `thenM` \ lie_binds ->
+
+ -- We want to keep non-recursive things non-recursive
+ -- so that we desugar unlifted bindings correctly
+ if isRec is_rec then
+ returnM (
+ combiner (mkMonoBind Recursive (
+ poly_binds `andMonoBinds`
+ lie_binds `andMonoBinds`
+ prag_binds)) thing
+ )
+ else
+ returnM (
+ combiner (mkMonoBind NonRecursive poly_binds) $
+ combiner (mkMonoBind NonRecursive prag_binds) $
+ combiner (mkMonoBind Recursive lie_binds) $
+ -- NB: the binds returned by tcSimplify and bindInstsOfLocalFuns
+ -- aren't guaranteed in dependency order (though we could change
+ -- that); hence the Recursive marker.
+ thing)
+ where
+ tc_body poly_ids -- Type check the pragmas and "thing inside"
+ = -- Extend the environment to bind the new polymorphic Ids
+ tcExtendLocalValEnv poly_ids $
+
+ -- Build bindings and IdInfos corresponding to user pragmas
+ tcSpecSigs sigs `thenM` \ prag_binds ->
+
+ -- Now do whatever happens next, in the augmented envt
+ do_next `thenM` \ thing ->
+
+ returnM (prag_binds, thing)
\end{code}
-Simple wrappers for export:
+
+%************************************************************************
+%* *
+\subsection{tcBindWithSigs}
+%* *
+%************************************************************************
+
+@tcBindWithSigs@ deals with a single binding group. It does generalisation,
+so all the clever stuff is in here.
+
+* binder_names and mbind must define the same set of Names
+
+* The Names in tc_ty_sigs must be a subset of binder_names
+
+* The Ids in tc_ty_sigs don't necessarily have to have the same name
+ as the Name in the tc_ty_sig
+
\begin{code}
-tcTopBindsAndThen
- :: E
- -> (TypecheckedBinds -> thing -> thing) -- Combinator
- -> RenamedBinds
- -> (E -> TcM (thing, LIE, anything))
- -> TcM (thing, LIE, anything)
-
-tcTopBindsAndThen e combiner binds do_next
- = tcBindsAndThen True e combiner binds do_next
-
-tcLocalBindsAndThen
- :: E
- -> (TypecheckedBinds -> thing -> thing) -- Combinator
- -> RenamedBinds
- -> (E -> TcM (thing, LIE, thing_ty))
- -> TcM (thing, LIE, thing_ty)
-
-tcLocalBindsAndThen e combiner binds do_next
- = tcBindsAndThen False e combiner binds do_next
+tcBindWithSigs
+ :: TopLevelFlag
+ -> RenamedMonoBinds
+ -> [RenamedSig] -- Used solely to get INLINE, NOINLINE sigs
+ -> RecFlag
+ -> TcM (TcMonoBinds, [TcId])
+
+tcBindWithSigs top_lvl mbind sigs is_rec
+ = -- TYPECHECK THE SIGNATURES
+ recoverM (returnM []) (
+ mappM tcTySig [sig | sig@(Sig name _ _) <- sigs]
+ ) `thenM` \ tc_ty_sigs ->
+
+ -- SET UP THE MAIN RECOVERY; take advantage of any type sigs
+ recoverM (
+ -- If typechecking the binds fails, then return with each
+ -- signature-less binder given type (forall a.a), to minimise subsequent
+ -- error messages
+ newTyVar liftedTypeKind `thenM` \ alpha_tv ->
+ let
+ forall_a_a = mkForAllTy alpha_tv (mkTyVarTy alpha_tv)
+ binder_names = collectMonoBinders mbind
+ poly_ids = map mk_dummy binder_names
+ mk_dummy name = case maybeSig tc_ty_sigs name of
+ Just sig -> tcSigPolyId sig -- Signature
+ Nothing -> mkLocalId name forall_a_a -- No signature
+ in
+ traceTc (text "tcBindsWithSigs: error recovery" <+> ppr binder_names) `thenM_`
+ returnM (EmptyMonoBinds, poly_ids)
+ ) $
+
+ -- TYPECHECK THE BINDINGS
+ getLIE (tcMonoBinds mbind tc_ty_sigs is_rec) `thenM` \ ((mbind', bndr_names_w_ids), lie_req) ->
+ let
+ (binder_names, mono_ids) = unzip (bagToList bndr_names_w_ids)
+ tau_tvs = foldr (unionVarSet . tyVarsOfType . idType) emptyVarSet mono_ids
+ in
+
+ -- GENERALISE
+ -- (it seems a bit crude to have to do getLIE twice,
+ -- but I can't see a better way just now)
+ addSrcLoc (minimum (map getSrcLoc binder_names)) $
+ addErrCtxt (genCtxt binder_names) $
+ getLIE (generalise binder_names mbind tau_tvs lie_req tc_ty_sigs)
+ `thenM` \ ((tc_tyvars_to_gen, dict_binds, dict_ids), lie_free) ->
+
+
+ -- ZONK THE GENERALISED TYPE VARIABLES TO REAL TyVars
+ -- This commits any unbound kind variables to boxed kind, by unification
+ -- It's important that the final quanfified type variables
+ -- are fully zonked, *including boxity*, because they'll be
+ -- included in the forall types of the polymorphic Ids.
+ -- At calls of these Ids we'll instantiate fresh type variables from
+ -- them, and we use their boxity then.
+ mappM zonkTcTyVarToTyVar tc_tyvars_to_gen `thenM` \ real_tyvars_to_gen ->
+
+ -- ZONK THE Ids
+ -- It's important that the dict Ids are zonked, including the boxity set
+ -- in the previous step, because they are later used to form the type of
+ -- the polymorphic thing, and forall-types must be zonked so far as
+ -- their bound variables are concerned
+ mappM zonkId dict_ids `thenM` \ zonked_dict_ids ->
+ mappM zonkId mono_ids `thenM` \ zonked_mono_ids ->
+
+ -- BUILD THE POLYMORPHIC RESULT IDs
+ let
+ exports = zipWith mk_export binder_names zonked_mono_ids
+ poly_ids = [poly_id | (_, poly_id, _) <- exports]
+ dict_tys = map idType zonked_dict_ids
+
+ inlines = mkNameSet [name | InlineSig True name _ loc <- sigs]
+ -- Any INLINE sig (regardless of phase control)
+ -- makes the RHS look small
+ inline_phases = listToFM [(name, phase) | InlineSig _ name phase _ <- sigs,
+ not (isAlwaysActive phase)]
+ -- Set the IdInfo field to control the inline phase
+ -- AlwaysActive is the default, so don't bother with them
+
+ mk_export binder_name zonked_mono_id
+ = (tyvars,
+ attachInlinePhase inline_phases poly_id,
+ zonked_mono_id)
+ where
+ (tyvars, poly_id) =
+ case maybeSig tc_ty_sigs binder_name of
+ Just (TySigInfo sig_poly_id sig_tyvars _ _ _ _ _) ->
+ (sig_tyvars, sig_poly_id)
+ Nothing -> (real_tyvars_to_gen, new_poly_id)
+
+ new_poly_id = mkLocalId binder_name poly_ty
+ poly_ty = mkForAllTys real_tyvars_to_gen
+ $ mkFunTys dict_tys
+ $ idType zonked_mono_id
+ -- It's important to build a fully-zonked poly_ty, because
+ -- we'll slurp out its free type variables when extending the
+ -- local environment (tcExtendLocalValEnv); if it's not zonked
+ -- it appears to have free tyvars that aren't actually free
+ -- at all.
+ in
+
+ traceTc (text "binding:" <+> ppr ((zonked_dict_ids, dict_binds),
+ exports, map idType poly_ids)) `thenM_`
+
+ -- Check for an unlifted, non-overloaded group
+ -- In that case we must make extra checks
+ if any (isUnLiftedType . idType) zonked_mono_ids && null zonked_dict_ids
+ then -- Some bindings are unlifted
+ checkUnliftedBinds top_lvl is_rec real_tyvars_to_gen mbind `thenM_`
+
+ extendLIEs lie_req `thenM_`
+ returnM (
+ AbsBinds [] [] exports inlines mbind',
+ -- Do not generate even any x=y bindings
+ poly_ids
+ )
+
+ else -- The normal case
+ extendLIEs lie_free `thenM_`
+ returnM (
+ AbsBinds real_tyvars_to_gen
+ zonked_dict_ids
+ exports
+ inlines
+ (dict_binds `andMonoBinds` mbind'),
+ poly_ids
+ )
+
+attachInlinePhase inline_phases bndr
+ = case lookupFM inline_phases (idName bndr) of
+ Just prag -> bndr `setInlinePragma` prag
+ Nothing -> bndr
+
+-- Check that non-overloaded unlifted bindings are
+-- a) non-recursive,
+-- b) not top level,
+-- c) non-polymorphic
+-- d) not a multiple-binding group (more or less implied by (a))
+
+checkUnliftedBinds top_lvl is_rec real_tyvars_to_gen mbind
+ = ASSERT( not (any ((eqKind unliftedTypeKind) . tyVarKind) real_tyvars_to_gen) )
+ -- The instCantBeGeneralised stuff in tcSimplify should have
+ -- already raised an error if we're trying to generalise an
+ -- unboxed tyvar (NB: unboxed tyvars are always introduced
+ -- along with a class constraint) and it's better done there
+ -- because we have more precise origin information.
+ -- That's why we just use an ASSERT here.
+
+ checkTc (isNotTopLevel top_lvl)
+ (unliftedBindErr "Top-level" mbind) `thenM_`
+ checkTc (isNonRec is_rec)
+ (unliftedBindErr "Recursive" mbind) `thenM_`
+ checkTc (single_bind mbind)
+ (unliftedBindErr "Multiple" mbind) `thenM_`
+ checkTc (null real_tyvars_to_gen)
+ (unliftedBindErr "Polymorphic" mbind)
+
+ where
+ single_bind (PatMonoBind _ _ _) = True
+ single_bind (FunMonoBind _ _ _ _) = True
+ single_bind other = False
\end{code}
-An aside. The original version of @tcBindsAndThen@ which lacks a
-combiner function, appears below. Though it is perfectly well
-behaved, it cannot be typed by Haskell, because the recursive call is
-at a different type to the definition itself. There aren't too many
-examples of this, which is why I thought it worth preserving! [SLPJ]
-\begin{pseudocode}
-tcBindsAndThen
- :: Bool -> E -> RenamedBinds
- -> (E -> TcM (thing, LIE, thing_ty))
- -> TcM ((TypecheckedBinds, thing), LIE, thing_ty)
+Polymorphic recursion
+~~~~~~~~~~~~~~~~~~~~~
+The game plan for polymorphic recursion in the code above is
-tcBindsAndThen top_level e EmptyBinds do_next
- = do_next e `thenTc` \ (thing, lie, thing_ty) ->
- returnTc ((EmptyBinds, thing), lie, thing_ty)
+ * Bind any variable for which we have a type signature
+ to an Id with a polymorphic type. Then when type-checking
+ the RHSs we'll make a full polymorphic call.
-tcBindsAndThen top_level e (SingleBind bind) do_next
- = tcBindAndThen top_level e bind [] do_next
+This fine, but if you aren't a bit careful you end up with a horrendous
+amount of partial application and (worse) a huge space leak. For example:
-tcBindsAndThen top_level e (BindWith bind sigs) do_next
- = tcBindAndThen top_level e bind sigs do_next
+ f :: Eq a => [a] -> [a]
+ f xs = ...f...
-tcBindsAndThen top_level e (ThenBinds binds1 binds2) do_next
- = tcBindsAndThen top_level e binds1 new_after
- `thenTc` \ ((binds1', (binds2', thing')), lie1, thing_ty) ->
+If we don't take care, after typechecking we get
- returnTc ((binds1' `ThenBinds` binds2', thing'), lie1, thing_ty)
+ 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.
- where
- -- new_after :: E -> TcM ((TypecheckedBinds, thing), LIE, thing_ty)
- -- Can't write this signature, cos it's monomorphic in thing and thing_ty
- new_after e = tcBindsAndThen top_level e binds2 do_next
-\end{pseudocode}
%************************************************************************
%* *
-\subsection{Bind}
+\subsection{getTyVarsToGen}
%* *
%************************************************************************
\begin{code}
-tcBindAndThen
- :: Bool -- At top level
- -> E
- -> (TypecheckedBinds -> thing -> thing) -- Combinator
- -> RenamedBind -- The Bind to typecheck
- -> [RenamedSig] -- ...and its signatures
- -> (E -> TcM (thing, LIE, thing_ty)) -- Thing to type check in
- -- augmented envt
- -> TcM (thing, LIE, thing_ty) -- Results, incl the
-
-tcBindAndThen top_level e combiner bind sigs do_next
- = -- Deal with the bind
- tcBind top_level e bind sigs `thenTc` \ (poly_binds, poly_lie, poly_lve) ->
-
- -- Now do whatever happens next, in the augmented envt
- do_next (growE_LVE e poly_lve) `thenTc` \ (thing, thing_lie, thing_ty) ->
- let
- bound_ids = map snd poly_lve
- in
- -- Create specialisations
- specialiseBinds bound_ids thing_lie poly_binds poly_lie
- `thenNF_Tc` \ (final_binds, final_lie) ->
- -- All done
- returnTc (combiner final_binds thing, final_lie, thing_ty)
-\end{code}
+generalise binder_names mbind tau_tvs lie_req sigs =
-\begin{code}
-tcBind :: Bool -> E
- -> RenamedBind -> [RenamedSig]
- -> TcM (TypecheckedBinds, LIE, LVE) -- LIE is a fixed point of substitution
+ -- check for -fno-monomorphism-restriction
+ doptM Opt_NoMonomorphismRestriction `thenM` \ no_MR ->
+ let is_unrestricted | no_MR = True
+ | otherwise = isUnRestrictedGroup tysig_names mbind
+ in
-tcBind False e bind sigs -- Not top level
- = tcBind_help False e bind sigs
+ if not is_unrestricted then -- RESTRICTED CASE
+ -- Check signature contexts are empty
+ checkTc (all is_mono_sig sigs)
+ (restrictedBindCtxtErr binder_names) `thenM_`
-tcBind True e bind sigs -- Top level!
- = pruneSubstTc (tvOfE e) (
+ -- Now simplify with exactly that set of tyvars
+ -- We have to squash those Methods
+ tcSimplifyRestricted doc tau_tvs lie_req `thenM` \ (qtvs, binds) ->
- -- DO THE WORK
- tcBind_help True e bind sigs `thenTc` \ (new_binds, lie, lve) ->
+ -- Check that signature type variables are OK
+ checkSigsTyVars qtvs sigs `thenM` \ final_qtvs ->
-{- Top-level unboxed values are now allowed
- They will be lifted by the Desugarer (see CoreLift.lhs)
+ returnM (final_qtvs, binds, [])
- -- CHECK FOR PRIMITIVE TOP-LEVEL BINDS
- listTc [ checkTc (isUnboxedDataType (getIdUniType id))
- (topLevelUnboxedDeclErr id (getSrcLoc id))
- | (_,id) <- lve ] `thenTc_`
--}
+ else if null sigs then -- UNRESTRICTED CASE, NO TYPE SIGS
+ tcSimplifyInfer doc tau_tvs lie_req
- -- Back-substitute over the binds, since we are about to discard
- -- a good chunk of the substitution.
- applyTcSubstToBinds new_binds `thenNF_Tc` \ final_binds ->
+ else -- UNRESTRICTED CASE, WITH TYPE SIGS
+ -- CHECKING CASE: Unrestricted group, there are type signatures
+ -- Check signature contexts are identical
+ checkSigsCtxts sigs `thenM` \ (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 `thenM` \ (forall_tvs, dict_binds) ->
+
+ -- Check that signature type variables are OK
+ checkSigsTyVars forall_tvs sigs `thenM` \ final_qtvs ->
- -- The lie is already a fixed point of the substitution; it just turns out
- -- that almost always this happens automatically, and so we made it part of
- -- the specification of genBinds.
- returnTc (final_binds, lie, lve)
- )
-\end{code}
+ returnM (final_qtvs, dict_binds, sig_dicts)
-\begin{code}
-tcBind_help top_level e bind sigs
- = -- Create an LVE binding each identifier to an appropriate type variable
- new_locals binders `thenNF_Tc` \ bound_ids ->
- let lve = binders `zip` bound_ids in
-
- -- Now deal with type signatures, if any
- tcSigs e lve sigs `thenTc` \ sig_info ->
-
- -- Check the bindings: this is the point at which we can use
- -- error recovery. If checking the bind fails we just
- -- return the empty bindings. The variables will still be in
- -- scope, but bound to completely free type variables, which
- -- is just what we want to minimise subsequent error messages.
- recoverTc (NonRecBind EmptyMonoBinds, nullLIE)
- (tc_bind (growE_LVE e lve) bind) `thenNF_Tc` \ (bind', lie) ->
-
- -- Notice that genBinds gets the old (non-extended) environment
- genBinds top_level e bind' lie lve sig_info `thenTc` \ (binds', lie, lve) ->
-
- -- Add bindings corresponding to SPECIALIZE pragmas in the code
- mapAndUnzipTc (doSpecPragma e (assoc "doSpecPragma" lve))
- (get_spec_pragmas sig_info)
- `thenTc` \ (spec_binds_s, spec_lie_s) ->
-
- returnTc (binds' `ThenBinds` (SingleBind (NonRecBind (
- foldr AndMonoBinds EmptyMonoBinds spec_binds_s))),
- lie `plusLIE` (foldr plusLIE nullLIE spec_lie_s),
- lve)
where
- binders = collectBinders bind
-
- new_locals binders
- = case bind of
- NonRecBind _ -> -- Recursive, so no unboxed types
- newLocalsWithOpenTyVarTys binders
+ tysig_names = map (idName . tcSigPolyId) 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)
+ = addSrcLoc src_loc $
+ mappM_ check_one other_sigs `thenM_`
+ if null theta1 then
+ returnM ([], []) -- Non-overloaded type signatures
+ else
+ newDicts SignatureOrigin theta1 `thenM` \ 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
+ returnM (sig_avails, map instToId sig_dicts)
+ where
+ sig1_dict_tys = map mkPredTy theta1
+ sig_meths = concat [insts | TySigInfo _ _ _ _ _ insts _ <- sigs]
- RecBind _ -> -- Non-recursive, so we permit unboxed types
- newLocalsWithPolyTyVarTys binders
+ check_one sig@(TySigInfo id _ theta _ _ _ _)
+ = addErrCtxt (sigContextsCtxt id1 id) $
+ checkTc (equalLength theta theta1) sigContextsErr `thenM_`
+ unifyTauTyLists sig1_dict_tys (map mkPredTy theta)
- get_spec_pragmas sig_info
- = catMaybes (map get_pragma_maybe sig_info)
- where
- get_pragma_maybe s@(ValSpecInfo _ _ _ _) = Just s
- get_pragma_maybe _ = Nothing
+checkSigsTyVars :: [TcTyVar] -> [TcSigInfo] -> TcM [TcTyVar]
+checkSigsTyVars qtvs sigs
+ = mappM check_one sigs `thenM` \ sig_tvs_s ->
+ let
+ -- Sigh. Make sure that all the tyvars in the type sigs
+ -- appear in the returned ty var list, which is what we are
+ -- going to generalise over. Reason: we occasionally get
+ -- silly types like
+ -- type T a = () -> ()
+ -- f :: T a
+ -- f () = ()
+ -- Here, 'a' won't appear in qtvs, so we have to add it
+
+ sig_tvs = foldr (unionVarSet . mkVarSet) emptyVarSet sig_tvs_s
+ all_tvs = mkVarSet qtvs `unionVarSet` sig_tvs
+ in
+ returnM (varSetElems all_tvs)
+ where
+ check_one (TySigInfo id sig_tyvars sig_theta sig_tau _ _ src_loc)
+ = addSrcLoc src_loc $
+ addErrCtxt (ptext SLIT("When checking the type signature for")
+ <+> quotes (ppr id)) $
+ addErrCtxtM (sigCtxt id sig_tyvars sig_theta sig_tau) $
+ checkSigTyVarsWrt (idFreeTyVars id) sig_tyvars
\end{code}
-\begin{verbatim}
- f :: Ord a => [a] -> b -> b
- {-# SPECIALIZE f :: [Int] -> b -> b #-}
-\end{verbatim}
-We generate:
-\begin{verbatim}
- f@Int = /\ b -> let d1 = ...
- in f Int b d1
+@getTyVarsToGen@ decides what type variables to generalise over.
+
+For a "restricted group" -- see the monomorphism restriction
+for a definition -- we bind no dictionaries, and
+remove from tyvars_to_gen any constrained type variables
+
+*Don't* simplify dicts at this point, because we aren't going
+to generalise over these dicts. By the time we do simplify them
+we may well know more. For example (this actually came up)
+ f :: Array Int Int
+ f x = array ... xs where xs = [1,2,3,4,5]
+We don't want to generate lots of (fromInt Int 1), (fromInt Int 2)
+stuff. If we simplify only at the f-binding (not the xs-binding)
+we'll know that the literals are all Ints, and we can just produce
+Int literals!
+
+Find all the type variables involved in overloading, the
+"constrained_tyvars". These are the ones we *aren't* going to
+generalise. We must be careful about doing this:
+
+ (a) If we fail to generalise a tyvar which is not actually
+ constrained, then it will never, ever get bound, and lands
+ up printed out in interface files! Notorious example:
+ instance Eq a => Eq (Foo a b) where ..
+ Here, b is not constrained, even though it looks as if it is.
+ Another, more common, example is when there's a Method inst in
+ the LIE, whose type might very well involve non-overloaded
+ type variables.
+ [NOTE: Jan 2001: I don't understand the problem here so I'm doing
+ the simple thing instead]
+
+ (b) On the other hand, we mustn't generalise tyvars which are constrained,
+ because we are going to pass on out the unmodified LIE, with those
+ tyvars in it. They won't be in scope if we've generalised them.
+
+So we are careful, and do a complete simplification just to find the
+constrained tyvars. We don't use any of the results, except to
+find which tyvars are constrained.
+\begin{code}
+isUnRestrictedGroup :: [Name] -- Signatures given for these
+ -> RenamedMonoBinds
+ -> Bool
+
+is_elem v vs = isIn "isUnResMono" v vs
+
+isUnRestrictedGroup sigs (PatMonoBind other _ _) = False
+isUnRestrictedGroup sigs (VarMonoBind v _) = v `is_elem` sigs
+isUnRestrictedGroup sigs (FunMonoBind v _ matches _) = isUnRestrictedMatch matches ||
+ v `is_elem` sigs
+isUnRestrictedGroup sigs (AndMonoBinds mb1 mb2) = isUnRestrictedGroup sigs mb1 &&
+ isUnRestrictedGroup sigs mb2
+isUnRestrictedGroup sigs EmptyMonoBinds = True
+
+isUnRestrictedMatch (Match [] _ _ : _) = False -- No args => like a pattern binding
+isUnRestrictedMatch other = True -- Some args => a function binding
+\end{code}
- h :: Ord a => [a] -> b -> b
- {-# SPECIALIZE h :: [Int] -> b -> b #-}
- spec_h = /\b -> h [Int] b dListOfInt
- ^^^^^^^^^^^^^^^^^^^^ This bit created by specId
-\end{verbatim}
+%************************************************************************
+%* *
+\subsection{tcMonoBind}
+%* *
+%************************************************************************
+
+@tcMonoBinds@ deals with a single @MonoBind@.
+The signatures have been dealt with already.
\begin{code}
-doSpecPragma :: E
- -> (Name -> Id)
- -> SignatureInfo
- -> TcM (TypecheckedMonoBinds, LIE)
-
-doSpecPragma e name_to_id (ValSpecInfo name spec_ty using src_loc)
- = let
- main_id = name_to_id name -- Get the parent Id
-
- main_id_ty = getIdUniType main_id
- main_id_free_tyvars = extractTyVarsFromTy main_id_ty
- origin = ValSpecOrigin name src_loc
- err_ctxt = ValSpecSigCtxt name spec_ty src_loc
- in
- addSrcLocTc src_loc (
- specTy origin spec_ty `thenNF_Tc` \ (spec_tyvars, spec_dicts, spec_tau) ->
-
- -- Check that the SPECIALIZE pragma had an empty context
- checkTc (not (null spec_dicts))
- (panic "SPECIALIZE non-empty context (ToDo: msg)") `thenTc_`
-
- -- Make an instance of this id
- specTy origin main_id_ty `thenNF_Tc` \ (main_tyvars, main_dicts, main_tau) ->
-
- -- Check that the specialised type is indeed an instance of
- -- the inferred type.
- -- The unification should leave all type vars which are
- -- currently free in the environment still free, and likewise
- -- the signature type vars.
- -- The only way type vars free in the envt could possibly be affected
- -- is if main_id_ty has free type variables. So we just extract them,
- -- and check that they are not constrained in any way by the unification.
- applyTcSubstAndCollectTyVars main_id_free_tyvars `thenNF_Tc` \ free_tyvars' ->
- unifyTauTy spec_tau main_tau err_ctxt `thenTc_`
- checkSigTyVars [] (spec_tyvars ++ free_tyvars')
- spec_tau main_tau err_ctxt `thenTc_`
-
- -- Check that the type variables of the polymorphic function are
- -- either left polymorphic, or instantiate to ground type.
- -- Also check that the overloaded type variables are instantiated to
- -- ground type; or equivalently that all dictionaries have ground type
- applyTcSubstToTyVars main_tyvars `thenNF_Tc` \ main_arg_tys ->
- applyTcSubstToInsts main_dicts `thenNF_Tc` \ main_dicts' ->
-
- checkTc (not (all isGroundOrTyVarTy main_arg_tys))
- (specGroundnessErr err_ctxt main_arg_tys)
- `thenTc_`
-
- checkTc (not (and [isGroundTy ty | (_,ty) <- map getDictClassAndType main_dicts']))
- (specCtxtGroundnessErr err_ctxt main_dicts')
- `thenTc_`
-
- -- Build a suitable binding; depending on whether we were given
- -- a value (Maybe Name) to be used as the specialisation.
- case using of
- Nothing ->
-
- -- Make a specPragmaId to which to bind the new call-instance
- newSpecPragmaId name spec_ty Nothing
- `thenNF_Tc` \ pseudo_spec_id ->
- let
- pseudo_bind = VarMonoBind pseudo_spec_id pseudo_rhs
- pseudo_rhs = mkTyLam spec_tyvars (mkDictApp (mkTyApp (Var main_id) main_arg_tys)
- (map mkInstId main_dicts'))
- in
- returnTc (pseudo_bind, mkLIE main_dicts')
+tcMonoBinds :: RenamedMonoBinds
+ -> [TcSigInfo] -> RecFlag
+ -> TcM (TcMonoBinds,
+ Bag (Name, -- Bound names
+ TcId)) -- Corresponding monomorphic bound things
+
+tcMonoBinds mbinds tc_ty_sigs is_rec
+ -- Three stages:
+ -- 1. Check the patterns, building up an environment binding
+ -- the variables in this group (in the recursive case)
+ -- 2. Extend the environment
+ -- 3. Check the RHSs
+ = tc_mb_pats mbinds `thenM` \ (complete_it, xve) ->
+ tcExtendLocalValEnv2 (bagToList xve) complete_it
+ where
+ tc_mb_pats EmptyMonoBinds
+ = returnM (returnM (EmptyMonoBinds, emptyBag), emptyBag)
- Just spec_name -> -- use spec_name as the specialisation value ...
+ tc_mb_pats (AndMonoBinds mb1 mb2)
+ = tc_mb_pats mb1 `thenM` \ (complete_it1, xve1) ->
+ tc_mb_pats mb2 `thenM` \ (complete_it2, xve2) ->
let
- spec_id = lookupE_Value e spec_name
- spec_id_ty = getIdUniType spec_id
-
- spec_id_free_tyvars = extractTyVarsFromTy spec_id_ty
- spec_id_ctxt = ValSpecSpecIdCtxt name spec_ty spec_name src_loc
-
- spec_tys = map maybe_ty main_arg_tys
- maybe_ty ty | isTyVarTy ty = Nothing
- | otherwise = Just ty
+ complete_it = complete_it1 `thenM` \ (mb1', bs1) ->
+ complete_it2 `thenM` \ (mb2', bs2) ->
+ returnM (AndMonoBinds mb1' mb2', bs1 `unionBags` bs2)
in
- -- Make an instance of the spec_id
- specTy origin spec_id_ty `thenNF_Tc` \ (spec_id_tyvars, spec_id_dicts, spec_id_tau) ->
-
- -- Check that the specialised type is indeed an instance of
- -- the type inferred for spec_id
- -- The unification should leave all type vars which are
- -- currently free in the environment still free, and likewise
- -- the signature type vars.
- -- The only way type vars free in the envt could possibly be affected
- -- is if spec_id_ty has free type variables. So we just extract them,
- -- and check that they are not constrained in any way by the unification.
- applyTcSubstAndCollectTyVars spec_id_free_tyvars `thenNF_Tc` \ spec_id_free_tyvars' ->
- unifyTauTy spec_tau spec_id_tau spec_id_ctxt `thenTc_`
- checkSigTyVars [] (spec_tyvars ++ spec_id_free_tyvars')
- spec_tau spec_id_tau spec_id_ctxt `thenTc_`
-
- -- Check that the type variables of the explicit spec_id are
- -- either left polymorphic, or instantiate to ground type.
- -- Also check that the overloaded type variables are instantiated to
- -- ground type; or equivalently that all dictionaries have ground type
- applyTcSubstToTyVars spec_id_tyvars `thenNF_Tc` \ spec_id_arg_tys ->
- applyTcSubstToInsts spec_id_dicts `thenNF_Tc` \ spec_id_dicts' ->
-
- checkTc (not (all isGroundOrTyVarTy spec_id_arg_tys))
- (specGroundnessErr spec_id_ctxt spec_id_arg_tys)
- `thenTc_`
-
- checkTc (not (and [isGroundTy ty | (_,ty) <- map getDictClassAndType spec_id_dicts']))
- (specCtxtGroundnessErr spec_id_ctxt spec_id_dicts')
- `thenTc_`
-
- -- Make a local SpecId to bind to applied spec_id
- newSpecId main_id spec_tys spec_ty `thenNF_Tc` \ local_spec_id ->
-
- -- Make a specPragmaId id with a spec_info for local_spec_id
- -- This is bound to local_spec_id
- -- The SpecInfo will be extracted by the specialiser and
- -- used to create a call instance for main_id (which is
- -- extracted from the spec_id)
- -- NB: the pseudo_local_id must stay in the scope of main_id !!!
- let
- spec_info = SpecInfo spec_tys (length main_dicts') local_spec_id
+ returnM (complete_it, xve1 `unionBags` xve2)
+
+ tc_mb_pats (FunMonoBind name inf matches locn)
+ -- Three cases:
+ -- a) Type sig supplied
+ -- b) No type sig and recursive
+ -- c) No type sig and non-recursive
+
+ | Just sig <- maybeSig tc_ty_sigs name
+ = let -- (a) There is a type signature
+ -- Use it for the environment extension, and check
+ -- the RHS has the appropriate type (with outer for-alls stripped off)
+ mono_id = tcSigMonoId sig
+ mono_ty = idType mono_id
+ complete_it = addSrcLoc locn $
+ tcMatchesFun name matches (Check mono_ty) `thenM` \ matches' ->
+ returnM (FunMonoBind mono_id inf matches' locn,
+ unitBag (name, mono_id))
in
- newSpecPragmaId name spec_ty (Just spec_info) `thenNF_Tc` \ pseudo_spec_id ->
+ returnM (complete_it, if isRec is_rec then unitBag (name,tcSigPolyId sig)
+ else emptyBag)
+
+ | isRec is_rec
+ = -- (b) No type signature, and recursive
+ -- So we must use an ordinary H-M type variable
+ -- which means the variable gets an inferred tau-type
+ newLocalName name `thenM` \ mono_name ->
+ newTyVarTy openTypeKind `thenM` \ mono_ty ->
let
- spec_bind = VarMonoBind local_spec_id spec_rhs
- spec_rhs = mkTyLam spec_tyvars (mkDictApp (mkTyApp (Var spec_id) spec_id_arg_tys)
- (map mkInstId spec_id_dicts'))
- pseudo_bind = VarMonoBind pseudo_spec_id (Var local_spec_id)
+ mono_id = mkLocalId mono_name mono_ty
+ complete_it = addSrcLoc locn $
+ tcMatchesFun name matches (Check mono_ty) `thenM` \ matches' ->
+ returnM (FunMonoBind mono_id inf matches' locn,
+ unitBag (name, mono_id))
in
- returnTc (spec_bind `AndMonoBinds` pseudo_bind, mkLIE spec_id_dicts')
- )
-\end{code}
-
-\begin{code}
-tc_bind :: E
- -> RenamedBind
- -> TcM (TypecheckedBind, LIE)
-
-tc_bind e (NonRecBind mono_binds)
- = tcMonoBinds e mono_binds `thenTc` \ (mono_binds2, lie) ->
- returnTc (NonRecBind mono_binds2, lie)
+ returnM (complete_it, unitBag (name, mono_id))
+
+ | otherwise -- (c) No type signature, and non-recursive
+ = let -- So we can use a 'hole' type to infer a higher-rank type
+ complete_it
+ = addSrcLoc locn $
+ newHole `thenM` \ hole ->
+ tcMatchesFun name matches (Infer hole) `thenM` \ matches' ->
+ readMutVar hole `thenM` \ fun_ty ->
+ newLocalName name `thenM` \ mono_name ->
+ let
+ mono_id = mkLocalId mono_name fun_ty
+ in
+ returnM (FunMonoBind mono_id inf matches' locn,
+ unitBag (name, mono_id))
+ in
+ returnM (complete_it, emptyBag)
+
+ tc_mb_pats bind@(PatMonoBind pat grhss locn)
+ = addSrcLoc locn $
+
+ -- Now typecheck the pattern
+ -- We do now support binding fresh (not-already-in-scope) scoped
+ -- type variables in the pattern of a pattern binding.
+ -- For example, this is now legal:
+ -- (x::a, y::b) = e
+ -- The type variables are brought into scope in tc_binds_and_then,
+ -- so we don't have to do anything here.
+
+ newHole `thenM` \ hole ->
+ tcPat tc_pat_bndr pat (Infer hole) `thenM` \ (pat', tvs, ids, lie_avail) ->
+ readMutVar hole `thenM` \ pat_ty ->
+
+ -- Don't know how to deal with pattern-bound existentials yet
+ checkTc (isEmptyBag tvs && null lie_avail)
+ (existentialExplode bind) `thenM_`
-tc_bind e (RecBind mono_binds)
- = tcMonoBinds e mono_binds `thenTc` \ (mono_binds2, lie) ->
- returnTc (RecBind mono_binds2, lie)
+ let
+ complete_it = addSrcLoc locn $
+ addErrCtxt (patMonoBindsCtxt bind) $
+ tcGRHSsPat grhss (Check pat_ty) `thenM` \ grhss' ->
+ returnM (PatMonoBind pat' grhss' locn, ids)
+ in
+ returnM (complete_it, if isRec is_rec then ids else emptyBag)
+
+ -- tc_pat_bndr is used when dealing with a LHS binder in a pattern.
+ -- If there was a type sig for that Id, we want to make it much
+ -- as if that type signature had been on the binder as a SigPatIn.
+ -- We check for a type signature; if there is one, we use the mono_id
+ -- from the signature. This is how we make sure the tau part of the
+ -- signature actually matches the type of the LHS; then tc_mb_pats
+ -- ensures the LHS and RHS have the same type
+
+ tc_pat_bndr name pat_ty
+ = case maybeSig tc_ty_sigs name of
+ Nothing -> newLocalName name `thenM` \ bndr_name ->
+ tcMonoPatBndr bndr_name pat_ty
+
+ Just sig -> addSrcLoc (getSrcLoc name) $
+ tcSubPat (idType mono_id) pat_ty `thenM` \ co_fn ->
+ returnM (co_fn, mono_id)
+ where
+ mono_id = tcSigMonoId sig
\end{code}
-\begin{code}
-specialiseBinds
- :: [Id] -- Ids bound in this group
- -> LIE -- LIE of scope of these bindings
- -> TypecheckedBinds
- -> LIE
- -> NF_TcM (TypecheckedBinds, LIE)
-
-specialiseBinds bound_ids lie_of_scope poly_binds poly_lie
- = bindInstsOfLocalFuns lie_of_scope bound_ids
- `thenNF_Tc` \ (lie2, inst_mbinds) ->
-
- returnNF_Tc (poly_binds `ThenBinds` (SingleBind (NonRecBind inst_mbinds)),
- lie2 `plusLIE` poly_lie)
-\end{code}
%************************************************************************
%* *
-\subsection{Signatures}
+\subsection{SPECIALIZE pragmas}
%* *
%************************************************************************
-@tcSigs@ checks the signatures for validity, and returns a list of
-{\em freshly-instantiated} signatures. That is, the types are already
-split up, and have fresh type variables (not @TyVarTemplate@s)
-installed.
+@tcSpecSigs@ munches up the specialisation "signatures" that arise through *user*
+pragmas. It is convenient for them to appear in the @[RenamedSig]@
+part of a binding because then the same machinery can be used for
+moving them into place as is done for type signatures.
-\begin{code}
-tcSigs :: E -> LVE
- -> [RenamedSig]
- -> TcM [SignatureInfo]
+They look like this:
-tcSigs e lve [] = returnTc []
+\begin{verbatim}
+ f :: Ord a => [a] -> b -> b
+ {-# SPECIALIZE f :: [Int] -> b -> b #-}
+\end{verbatim}
-tcSigs e lve (s:ss)
- = tc_sig s `thenTc` \ sig_info1 ->
- tcSigs e lve ss `thenTc` \ sig_info2 ->
- returnTc (sig_info1 : sig_info2)
- where
- tc_sig (Sig v ty _ src_loc) -- no interesting pragmas on non-iface sigs
- = addSrcLocTc src_loc (
+For this we generate:
+\begin{verbatim}
+ f* = /\ b -> let d1 = ...
+ in f Int b d1
+\end{verbatim}
- babyTcMtoTcM
- (tcPolyType (getE_CE e) (getE_TCE e) nullTVE ty) `thenTc` \ sigma_ty ->
+where f* is a SpecPragmaId. The **sole** purpose of SpecPragmaIds is to
+retain a right-hand-side that the simplifier will otherwise discard as
+dead code... the simplifier has a flag that tells it not to discard
+SpecPragmaId bindings.
- let val = assoc "tcSigs" lve v in
- -- (The renamer/dependency-analyser should have ensured
- -- that there are only signatures for which there is a
- -- corresponding binding.)
+In this case the f* retains a call-instance of the overloaded
+function, f, (including appropriate dictionaries) so that the
+specialiser will subsequently discover that there's a call of @f@ at
+Int, and will create a specialisation for @f@. After that, the
+binding for @f*@ can be discarded.
- -- Instantiate the type, and unify with the type variable
- -- found in the Id.
- specTy SignatureOrigin sigma_ty `thenNF_Tc` \ (tyvars, dicts, tau_ty) ->
- unifyTauTy (getIdUniType val) tau_ty
- (panic "ToDo: unifyTauTy(tcSigs)") `thenTc_`
+We used to have a form
+ {-# SPECIALISE f :: <type> = g #-}
+which promised that g implemented f at <type>, but we do that with
+a RULE now:
+ {-# SPECIALISE (f::<type) = g #-}
- returnTc (TySigInfo val tyvars dicts tau_ty src_loc)
- )
+\begin{code}
+tcSpecSigs :: [RenamedSig] -> TcM TcMonoBinds
+tcSpecSigs (SpecSig name poly_ty src_loc : sigs)
+ = -- SPECIALISE f :: forall b. theta => tau = g
+ addSrcLoc src_loc $
+ addErrCtxt (valSpecSigCtxt name poly_ty) $
+
+ -- Get and instantiate its alleged specialised type
+ tcHsSigType (FunSigCtxt name) poly_ty `thenM` \ sig_ty ->
+
+ -- Check that f has a more general type, and build a RHS for
+ -- the spec-pragma-id at the same time
+ getLIE (tcCheckSigma (HsVar name) sig_ty) `thenM` \ (spec_expr, spec_lie) ->
+
+ -- Squeeze out any Methods (see comments with tcSimplifyToDicts)
+ tcSimplifyToDicts spec_lie `thenM` \ spec_binds ->
+
+ -- Just specialise "f" by building a SpecPragmaId binding
+ -- It is the thing that makes sure we don't prematurely
+ -- dead-code-eliminate the binding we are really interested in.
+ newLocalName name `thenM` \ spec_name ->
+ let
+ spec_bind = VarMonoBind (mkSpecPragmaId spec_name sig_ty)
+ (mkHsLet spec_binds spec_expr)
+ in
- tc_sig (SpecSig v ty using src_loc)
- = addSrcLocTc src_loc (
+ -- Do the rest and combine
+ tcSpecSigs sigs `thenM` \ binds_rest ->
+ returnM (binds_rest `andMonoBinds` spec_bind)
- babyTcMtoTcM
- (tcPolyType (getE_CE e) (getE_TCE e) nullTVE ty) `thenTc` \ sigma_ty ->
+tcSpecSigs (other_sig : sigs) = tcSpecSigs sigs
+tcSpecSigs [] = returnM EmptyMonoBinds
+\end{code}
- returnTc (ValSpecInfo v sigma_ty using src_loc)
- )
- tc_sig (InlineSig v guide locn)
- = returnTc (ValInlineInfo v guide locn)
+%************************************************************************
+%* *
+\subsection[TcBinds-errors]{Error contexts and messages}
+%* *
+%************************************************************************
- tc_sig (DeforestSig v locn)
- = returnTc (ValDeforestInfo v locn)
- tc_sig (MagicUnfoldingSig v str locn)
- = returnTc (ValMagicUnfoldingInfo v str locn)
+\begin{code}
+patMonoBindsCtxt bind
+ = hang (ptext SLIT("In a pattern binding:")) 4 (ppr bind)
+
+-----------------------------------------------
+valSpecSigCtxt v ty
+ = sep [ptext SLIT("In a SPECIALIZE pragma for a value:"),
+ nest 4 (ppr v <+> dcolon <+> ppr ty)]
+
+-----------------------------------------------
+sigContextsErr = ptext SLIT("Mismatched contexts")
+
+sigContextsCtxt s1 s2
+ = vcat [ptext SLIT("When matching the contexts of the signatures for"),
+ nest 2 (vcat [ppr s1 <+> dcolon <+> ppr (idType s1),
+ ppr s2 <+> dcolon <+> ppr (idType s2)]),
+ ptext SLIT("The signature contexts in a mutually recursive group should all be identical")]
+
+-----------------------------------------------
+unliftedBindErr flavour mbind
+ = hang (text flavour <+> ptext SLIT("bindings for unlifted types aren't allowed:"))
+ 4 (ppr mbind)
+
+-----------------------------------------------
+existentialExplode mbinds
+ = hang (vcat [text "My brain just exploded.",
+ text "I can't handle pattern bindings for existentially-quantified constructors.",
+ text "In the binding group"])
+ 4 (ppr mbinds)
+
+-----------------------------------------------
+restrictedBindCtxtErr binder_names
+ = hang (ptext SLIT("Illegal overloaded type signature(s)"))
+ 4 (vcat [ptext SLIT("in a binding group for") <+> pprBinders binder_names,
+ ptext SLIT("that falls under the monomorphism restriction")])
+
+genCtxt binder_names
+ = ptext SLIT("When generalising the type(s) for") <+> pprBinders binder_names
+
+-- Used in error messages
+-- Use quotes for a single one; they look a bit "busy" for several
+pprBinders [bndr] = quotes (ppr bndr)
+pprBinders bndrs = pprWithCommas ppr bndrs
\end{code}
projects / ghc-hetmet.git / blobdiff