%************************************************************************
\begin{code}
-data RecFlag
- = Recursive
- | NonRecursive
+data RecFlag = Recursive
+ | NonRecursive
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Strictness indication}
+%* *
+%************************************************************************
+
+\begin{code}
+data StrictnessMark = MarkedStrict
+ | NotMarkedStrict
\end{code}
_declarations_
1 mkDataCon _:_ Name.Name -> [Id!StrictnessMark] -> [FieldLabel!FieldLabel] -> [TyVar.TyVar] -> Type.ThetaType -> [TyVar.TyVar] -> Type!ThetaType -> [Type!TauType] -> TyCon!TyCon -> Id!Id ;;
1 mkTupleCon _:_ PrelBase.Int -> Name.Name -> Type!Type -> Id!Id ;;
-
mkImportedId,
mkUserId,
mkUserLocal, mkSysLocal,
+ mkSpecPragmaId,
mkDataCon, mkTupleCon,
mkUserLocal occ uniq ty loc
= mkVanillaId (mkLocalName uniq occ loc) ty noIdInfo
+mkSpecPragmaId occ uniq ty loc
+ = mkId (mkLocalName uniq occ loc) ty SpecPragmaId noIdInfo
+
mkUserId :: Name -> GenType flexi -> GenId (GenType flexi)
mkUserId name ty
= mkVanillaId name ty noIdInfo
import Bag
import Kind ( hasMoreBoxityInfo, Kind{-instance-} )
import Literal ( literalType, Literal{-instance-} )
-import Id ( idType, isBottomingId, dataConRepType, isDataCon, isNewCon, isAlgCon,
+import Id ( idType, isBottomingId, dataConRepType, isDataCon, isAlgCon,
dataConArgTys, GenId{-instances-},
emptyIdSet, mkIdSet,
unionIdSets, elementOfIdSet, IdSet,
)
import Maybes ( catMaybes )
import Name ( isLocallyDefined, getSrcLoc, Name{-instance NamedThing-},
- NamedThing(..) )
+ NamedThing(..)
+ )
import PprCore
import ErrUtils ( doIfSet, ghcExit )
import PrimOp ( primOpType )
| InlineSig name -- INLINE f
SrcLoc
- | MagicUnfoldingSig
- name -- Associate the "name"d function with
- FAST_STRING -- the compiler-builtin unfolding (known
- SrcLoc -- by the String name)
+ | SpecInstSig (HsType name) -- (Class tys); should be a specialisation of the
+ -- current instance decl
+ SrcLoc
+\end{code}
+
+\begin{code}
+sigsForMe :: (name -> Bool) -> [Sig name] -> [Sig name]
+sigsForMe f sigs
+ = filter sig_for_me sigs
+ where
+ sig_for_me (Sig n _ _) = f n
+ sig_for_me (ClassOpSig n _ _ _) = f n
+ sig_for_me (SpecSig n _ _ _) = f n
+ sig_for_me (InlineSig n _) = f n
+ sig_for_me (SpecInstSig _ _) = False
\end{code}
\begin{code}
ppr_sig (InlineSig var _)
= hsep [text "{-# INLINE", ppr var, text "#-}"]
-ppr_sig (MagicUnfoldingSig var str _)
- = hsep [text "{-# MAGIC_UNFOLDING", ppr var, ptext str, text "#-}"]
+ppr_sig (SpecInstSig ty _)
+ = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
\end{code}
%************************************************************************
%* *
-\subsection[InstDecl]{An instance declaration (also, @SpecInstSig@)}
+\subsection[InstDecl]{An instance declaration
%* *
%************************************************************************
nest 4 (ppr binds) ]
\end{code}
-A type for recording what instances the user wants to specialise;
-called a ``Sig'' because it's sort of like a ``type signature'' for an
-instance.
-\begin{code}
-data SpecInstSig name
- = SpecInstSig name -- class
- (HsType name) -- type to specialise to
- SrcLoc
-
-instance (NamedThing name, Outputable name)
- => Outputable (SpecInstSig name) where
-
- ppr (SpecInstSig clas ty _)
- = hsep [text "{-# SPECIALIZE instance", ppr clas, ppr ty, text "#-}"]
-\end{code}
%************************************************************************
%* *
DefaultDecl(..),
FixityDecl(..),
ConDecl(..), ConDetails(..), BangType(..),
- IfaceSig(..), HsIdInfo, SpecDataSig(..), SpecInstSig(..),
+ IfaceSig(..), HsIdInfo, SpecDataSig(..),
hsDeclName
)
import HsExpr
-- signatures are mysterious; we can't
-- tell if its a Sig or a ClassOpSig,
-- so we just save the pieces:
- | RdrTySig [RdrName] -- vars getting sigs
- RdrNameHsType -- the type
- SrcLoc
-
- -- user pragmas come in in a Sig-ish way/form...
- | RdrSpecValSig [RdrNameSig]
- | RdrInlineValSig RdrNameSig
- | RdrMagicUnfoldingSig RdrNameSig
- | RdrSpecInstSig RdrNameSpecInstSig
- | RdrSpecDataSig RdrNameSpecDataSig
-
-type SigConverter = RdrBinding {- a Sig -} -> [RdrNameSig]
+ | RdrSig RdrNameSig
+
+type SigConverter = RdrNameSig -> RdrNameSig
\end{code}
\begin{code}
We make a point not to throw any user-pragma ``sigs'' at
these conversion functions:
+
\begin{code}
cvValSig, cvClassOpSig, cvInstDeclSig :: SigConverter
-cvValSig (RdrTySig vars poly_ty src_loc)
- = [ Sig v poly_ty src_loc | v <- vars ]
+cvValSig sig = sig
-cvClassOpSig (RdrTySig vars poly_ty src_loc)
- = [ ClassOpSig v Nothing poly_ty src_loc | v <- vars ]
+cvInstDeclSig sig = sig
-cvInstDeclSig (RdrSpecValSig sigs) = sigs
-cvInstDeclSig (RdrInlineValSig sig) = [ sig ]
-cvInstDeclSig (RdrMagicUnfoldingSig sig) = [ sig ]
+cvClassOpSig (Sig var poly_ty src_loc) = ClassOpSig var Nothing poly_ty src_loc
+cvClassOpSig sig = sig
\end{code}
+
%************************************************************************
%* *
\subsection[cvBinds-etc]{Converting to @HsBinds@, @MonoBinds@, etc.}
mangle_bind acc (RdrAndBindings fb1 fb2)
= mangle_bind (mangle_bind acc fb1) fb2
- mangle_bind (b_acc, s_acc) sig@(RdrTySig _ _ _)
- = (b_acc, s_acc ++ sig_cvtr sig)
-
- mangle_bind (b_acc, s_acc) (RdrSpecValSig sig) = (b_acc, sig ++ s_acc)
- mangle_bind (b_acc, s_acc) (RdrInlineValSig sig) = (b_acc, sig : s_acc)
- mangle_bind (b_acc, s_acc) (RdrMagicUnfoldingSig sig) = (b_acc, sig : s_acc)
+ mangle_bind (b_acc, s_acc) (RdrSig sig)
+ = (b_acc, sig_cvtr sig : s_acc)
mangle_bind (b_acc, s_acc)
(RdrPatternBinding lousy_srcline [patbinding])
RdrNamePat,
RdrNameHsType,
RdrNameSig,
- RdrNameSpecInstSig,
RdrNameStmt,
RdrNameTyDecl,
type RdrNamePat = InPat RdrName
type RdrNameHsType = HsType RdrName
type RdrNameSig = Sig RdrName
-type RdrNameSpecInstSig = SpecInstSig RdrName
type RdrNameStmt = Stmt Unused RdrName RdrNamePat
type RdrNameTyDecl = TyDecl RdrName
= mkSrcLocUgn srcline $ \ src_loc ->
wlkList rdVarId sbindids `thenUgn` \ vars ->
wlkHsType sbindid `thenUgn` \ poly_ty ->
- returnUgn (RdrTySig vars poly_ty src_loc)
+ returnUgn (foldr1 RdrAndBindings [RdrSig (Sig var poly_ty src_loc) | var <- vars])
-- value specialisation user-pragma
wlk_sig_thing (U_vspec_uprag uvar vspec_tys srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
wlkVarId uvar `thenUgn` \ var ->
wlkList rd_ty_and_id vspec_tys `thenUgn` \ tys_and_ids ->
- returnUgn (RdrSpecValSig [SpecSig var ty using_id src_loc
- | (ty, using_id) <- tys_and_ids ])
+ returnUgn (foldr1 RdrAndBindings [ RdrSig (SpecSig var ty using_id src_loc)
+ | (ty, using_id) <- tys_and_ids ])
where
rd_ty_and_id :: ParseTree -> UgnM (RdrNameHsType, Maybe RdrName)
rd_ty_and_id pt
-- instance specialisation user-pragma
wlk_sig_thing (U_ispec_uprag iclas ispec_ty srcline)
- = mkSrcLocUgn srcline $ \ src_loc ->
- wlkTCId iclas `thenUgn` \ clas ->
- wlkMonoType ispec_ty `thenUgn` \ ty ->
- returnUgn (RdrSpecInstSig (SpecInstSig clas ty src_loc))
-
- -- data specialisation user-pragma
-wlk_sig_thing (U_dspec_uprag itycon dspec_tys srcline)
- = mkSrcLocUgn srcline $ \ src_loc ->
- wlkTCId itycon `thenUgn` \ tycon ->
- wlkList rdMonoType dspec_tys `thenUgn` \ tys ->
- returnUgn (RdrSpecDataSig (SpecDataSig tycon (foldl MonoTyApp (MonoTyVar tycon) tys) src_loc))
+ = mkSrcLocUgn srcline $ \ src_loc ->
+ wlkHsType ispec_ty `thenUgn` \ ty ->
+ returnUgn (RdrSig (SpecInstSig ty src_loc))
-- value inlining user-pragma
wlk_sig_thing (U_inline_uprag ivar srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
wlkVarId ivar `thenUgn` \ var ->
- returnUgn (RdrInlineValSig (InlineSig var src_loc))
-
- -- "magic" unfolding user-pragma
-wlk_sig_thing (U_magicuf_uprag ivar str srcline)
- = mkSrcLocUgn srcline $ \ src_loc ->
- wlkVarId ivar `thenUgn` \ var ->
- returnUgn (RdrMagicUnfoldingSig (MagicUnfoldingSig var str src_loc))
+ returnUgn (RdrSig (InlineSig var src_loc))
\end{code}
%************************************************************************
\begin{code}
module RnBinds (
rnTopBinds, rnTopMonoBinds,
- rnMethodBinds,
+ rnMethodBinds, renameSigs,
rnBinds, rnMonoBinds
) where
import {-# SOURCE #-} RnSource ( rnHsSigType )
import HsSyn
+import HsBinds ( sigsForMe )
import RdrHsSyn
import RnHsSyn
import RnMonad
-- Rename the bindings, returning a MonoBindsInfo
-- which is a list of indivisible vertices so far as
-- the strongly-connected-components (SCC) analysis is concerned
- rnBindSigs top_lev binders sigs `thenRn` \ siglist ->
+ renameSigs top_lev False binders sigs `thenRn` \ siglist ->
flattenMonoBinds siglist mbinds `thenRn` \ mbinds_info ->
-- Do the SCC analysis
-- Find which things are bound in this group
let
names_bound_here = mkNameSet (collectPatBinders pat')
- sigs_for_me = filter ((`elemNameSet` names_bound_here) . sig_name) sigs
+ sigs_for_me = sigsForMe (`elemNameSet` names_bound_here) sigs
sigs_fvs = foldr sig_fv emptyNameSet sigs_for_me
in
returnRn
mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, fv_lists) ->
let
fvs = unionManyNameSets fv_lists
- sigs_for_me = filter ((name' ==) . sig_name) sigs
+ sigs_for_me = sigsForMe (name' ==) sigs
sigs_fvs = foldr sig_fv emptyNameSet sigs_for_me
in
returnRn
%* *
%************************************************************************
-@rnBindSigs@ checks for: (a)~more than one sig for one thing;
+@renameSigs@ checks for: (a)~more than one sig for one thing;
(b)~signatures given for things not bound here; (c)~with suitably
flaggery, that all top-level things have type signatures.
\begin{code}
-rnBindSigs :: TopLevelFlag
- -> NameSet -- Set of names bound in this group
- -> [RdrNameSig]
- -> RnMS s [RenamedSig] -- List of Sig constructors
-
-rnBindSigs top_lev binders sigs
+renameSigs :: TopLevelFlag
+ -> Bool -- True <-> sigs for an instance decl
+ -- hence SPECIALISE instance prags ok
+ -> NameSet -- Set of names bound in this group
+ -> [RdrNameSig]
+ -> RnMS s [RenamedSig] -- List of Sig constructors
+
+renameSigs top_lev inst_decl binders sigs
= -- Rename the signatures
mapRn renameSig sigs `thenRn` \ sigs' ->
-- (b) signatures for things not in this group
-- (c) optionally, bindings with no signature
let
- (goodies, dups) = removeDups cmp_sig (filter (not.isUnboundName.sig_name) sigs')
- not_this_group = filter (\sig -> not (sig_name sig `elemNameSet` binders)) goodies
+ (goodies, dups) = removeDups cmp_sig (sigsForMe (not . isUnboundName) sigs')
+ not_this_group = sigsForMe (not . (`elemNameSet` binders)) goodies
+ spec_inst_sigs = [s | s@(SpecInstSig _ _) <- goodies]
type_sig_vars = [n | Sig n _ _ <- goodies]
sigs_required = case top_lev of {TopLevel -> opt_SigsRequired; NotTopLevel -> False}
un_sigd_binders | sigs_required = nameSetToList binders `minusList` type_sig_vars
in
mapRn dupSigDeclErr dups `thenRn_`
mapRn unknownSigErr not_this_group `thenRn_`
+ (if not inst_decl then
+ mapRn unknownSigErr spec_inst_sigs
+ else
+ returnRn []
+ ) `thenRn_`
mapRn (addErrRn.missingSigErr) un_sigd_binders `thenRn_`
returnRn sigs' -- bad ones and all:
rnHsSigType (quotes (ppr v)) ty `thenRn` \ new_ty ->
returnRn (Sig new_v new_ty src_loc)
+renameSig (SpecInstSig ty src_loc)
+ = pushSrcLocRn src_loc $
+ rnHsSigType (text "A SPECIALISE instance pragma") ty `thenRn` \ new_ty ->
+ returnRn (SpecInstSig new_ty src_loc)
+
renameSig (SpecSig v ty using src_loc)
= pushSrcLocRn src_loc $
lookupBndrRn v `thenRn` \ new_v ->
= pushSrcLocRn src_loc $
lookupBndrRn v `thenRn` \ new_v ->
returnRn (InlineSig new_v src_loc)
-
-renameSig (MagicUnfoldingSig v str src_loc)
- = pushSrcLocRn src_loc $
- lookupBndrRn v `thenRn` \ new_v ->
- returnRn (MagicUnfoldingSig new_v str src_loc)
\end{code}
Checking for distinct signatures; oh, so boring
\begin{code}
cmp_sig :: RenamedSig -> RenamedSig -> Ordering
-cmp_sig (Sig n1 _ _) (Sig n2 _ _) = n1 `compare` n2
-cmp_sig (InlineSig n1 _) (InlineSig n2 _) = n1 `compare` n2
-cmp_sig (MagicUnfoldingSig n1 _ _) (MagicUnfoldingSig n2 _ _) = n1 `compare` n2
-cmp_sig (SpecSig n1 ty1 _ _) (SpecSig n2 ty2 _ _)
+cmp_sig (Sig n1 _ _) (Sig n2 _ _) = n1 `compare` n2
+cmp_sig (InlineSig n1 _) (InlineSig n2 _) = n1 `compare` n2
+cmp_sig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = cmpHsType compare ty1 ty2
+cmp_sig (SpecSig n1 ty1 _ _) (SpecSig n2 ty2 _ _)
= -- may have many specialisations for one value;
-- but not ones that are exactly the same...
thenCmp (n1 `compare` n2) (cmpHsType compare ty1 ty2)
sig_tag (Sig n1 _ _) = (ILIT(1) :: FAST_INT)
sig_tag (SpecSig n1 _ _ _) = ILIT(2)
sig_tag (InlineSig n1 _) = ILIT(3)
-sig_tag (MagicUnfoldingSig n1 _ _) = ILIT(4)
+sig_tag (SpecInstSig _ _) = ILIT(5)
sig_tag _ = panic# "tag(RnBinds)"
-
-sig_name (Sig n _ _) = n
-sig_name (ClassOpSig n _ _ _) = n
-sig_name (SpecSig n _ _ _) = n
-sig_name (InlineSig n _) = n
-sig_name (MagicUnfoldingSig n _ _) = n
\end{code}
%************************************************************************
\begin{code}
dupSigDeclErr (sig:sigs)
= pushSrcLocRn loc $
- addErrRn (sep [ptext SLIT("more than one"),
- ptext what_it_is, ptext SLIT("given for"),
- quotes (ppr (sig_name sig))])
+ addErrRn (sep [ptext SLIT("Duplicate"),
+ ptext what_it_is <> colon,
+ ppr sig])
where
(what_it_is, loc) = sig_doc sig
unknownSigErr sig
= pushSrcLocRn loc $
- addErrRn (sep [ptext flavour, ptext SLIT("but no definition for"),
- quotes (ppr (sig_name sig))])
+ addErrRn (sep [ptext SLIT("Misplaced"),
+ ptext what_it_is <> colon,
+ ppr sig])
where
- (flavour, loc) = sig_doc sig
+ (what_it_is, loc) = sig_doc sig
sig_doc (Sig _ _ loc) = (SLIT("type signature"),loc)
sig_doc (ClassOpSig _ _ _ loc) = (SLIT("class-method type signature"), loc)
-sig_doc (SpecSig _ _ _ loc) = (SLIT("SPECIALIZE pragma"),loc)
+sig_doc (SpecSig _ _ _ loc) = (SLIT("SPECIALISE pragma"),loc)
sig_doc (InlineSig _ loc) = (SLIT("INLINE pragma"),loc)
-sig_doc (MagicUnfoldingSig _ _ loc) = (SLIT("MAGIC_UNFOLDING pragma"),loc)
+sig_doc (SpecInstSig _ loc) = (SLIT("SPECIALISE instance pragma"),loc)
missingSigErr var
= sep [ptext SLIT("Definition but no type signature for"), quotes (ppr var)]
type RenamedHsType = HsType Name
type RenamedRecordBinds = HsRecordBinds Unused Name RenamedPat
type RenamedSig = Sig Name
-type RenamedSpecInstSig = SpecInstSig Name
type RenamedStmt = Stmt Unused Name RenamedPat
type RenamedTyDecl = TyDecl Name
import HsCore
import CmdLineOpts ( opt_IgnoreIfacePragmas )
-import RnBinds ( rnTopBinds, rnMethodBinds )
+import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs )
import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn, lookupImplicitOccRn, bindLocalsRn,
newDfunName, checkDupOrQualNames, checkDupNames,
newLocallyDefinedGlobalName, newImportedGlobalName, ifaceFlavour,
import RnMonad
import Name ( Name, OccName(..), occNameString, prefixOccName,
- ExportFlag(..), Provenance(..), NameSet,
+ ExportFlag(..), Provenance(..), NameSet, mkNameSet,
elemNameSet, nameOccName, NamedThing(..)
)
+import BasicTypes ( TopLevelFlag(..) )
import FiniteMap ( lookupFM )
import Id ( GenId{-instance NamedThing-} )
import IdInfo ( FBTypeInfo, ArgUsageInfo )
where
cls_doc = text "the declaration for class" <+> ppr cname
sig_doc = text "the signatures for class" <+> ppr cname
- meth_doc = text "the default-methods for class" <+> ppr cname
+ meth_doc = text "the default-methods for class" <+> ppr cname
sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
meth_rdr_names_w_locs = bagToList (collectMonoBinders mbinds)
-- NB meth_names can be qualified!
checkDupNames meth_doc meth_names `thenRn_`
rnMethodBinds mbinds `thenRn` \ mbinds' ->
- mapRn rn_uprag uprags `thenRn` \ new_uprags ->
+ let
+ binders = mkNameSet (map fst (bagToList (collectMonoBinders mbinds')))
+ in
+ renameSigs NotTopLevel True binders uprags `thenRn` \ new_uprags ->
let
-- We use the class name and the name of the first
where
meth_doc = text "the bindings in an instance declaration"
meth_names = bagToList (collectMonoBinders mbinds)
-
- rn_uprag (SpecSig op ty using locn)
- = pushSrcLocRn src_loc $
- lookupBndrRn op `thenRn` \ op_name ->
- rnHsSigType (quotes (ppr op)) ty `thenRn` \ new_ty ->
- rn_using using `thenRn` \ new_using ->
- returnRn (SpecSig op_name new_ty new_using locn)
-
- rn_uprag (InlineSig op locn)
- = pushSrcLocRn locn $
- lookupBndrRn op `thenRn` \ op_name ->
- returnRn (InlineSig op_name locn)
-
- rn_uprag (MagicUnfoldingSig op str locn)
- = pushSrcLocRn locn $
- lookupBndrRn op `thenRn` \ op_name ->
- returnRn (MagicUnfoldingSig op_name str locn)
-
- rn_using Nothing = returnRn Nothing
- rn_using (Just v) = lookupOccRn v `thenRn` \ new_v ->
- returnRn (Just new_v)
\end{code}
%*********************************************************
import CoreSyn
import Digraph ( stronglyConnCompR, SCC(..) )
import Id ( idWantsToBeINLINEd, addNoInlinePragma, nukeNoInlinePragma,
- omitIfaceSigForId,
+ omitIfaceSigForId, isSpecPragmaId,
idType, idUnique, Id,
emptyIdSet, unionIdSets, mkIdSet,
elementOfIdSet,
usage_of usage binder
- | isExported binder
+ | isExported binder || isSpecPragmaId binder
= noBinderInfo -- Visible-elsewhere things count as many
| otherwise
= case (lookupIdEnv usage binder) of
import MkId ( mkUserLocal )
import Id ( Id, DictVar, idType,
- getIdSpecialisation, setIdSpecialisation,
+ getIdSpecialisation, setIdSpecialisation, isSpecPragmaId,
IdSet, mkIdSet, addOneToIdSet, intersectIdSets, isEmptyIdSet,
emptyIdSet, unionIdSets, minusIdSet, unitIdSet, elementOfIdSet,
%************************************************************************
These notes describe how we implement specialisation to eliminate
-overloading, and optionally to eliminate unboxed polymorphism, and
-full polymorphism.
+overloading.
-The specialisation pass is a partial evaluator which works on Core
+The specialisation pass works on Core
syntax, complete with all the explicit dictionary application,
abstraction and construction as added by the type checker. The
existing type checker remains largely as it is.
f@t1/t2 = <f_rhs> t1 t2 d1 d2
-(f_rhs presumably has some big lambdas and dictionary lambdas, so lots
-of simplification will now result.) Then we should recursively do
-everything again.
-
-The new id has its own unique, but its print-name (if exported) has
-an explicit representation of the instance types t1/t2.
+f_rhs presumably has some big lambdas and dictionary lambdas, so lots
+of simplification will now result. However we don't actually *do* that
+simplification. Rather, we leave it for the simplifier to do. If we
+*did* do it, though, we'd get more call instances from the specialised
+RHS. We can work out what they are by instantiating the call-instance
+set from f's RHS with the types t1, t2.
Add this new id to f's IdInfo, to record that f has a specialised version.
in
fl
-We still have recusion for non-overloadd functions which we
-speciailise, but the recursive call should get speciailised to the
+We still have recusion for non-overloaded functions which we
+speciailise, but the recursive call should get specialised to the
same recursive version.
f@t1/ = /\b -> <f_rhs> t1 b d1 d2
-This seems pretty simple, and a Good Thing.
+We do this.
-Polymorphism 3 -- Unboxed
-~~~~~~~~~~~~~~
-If we are speciailising at unboxed types we must speciailise
-regardless of the overloading constraint. In the exaple above it is
-worth speciailising at types Int/Int#, Int/Bool# and a/Int#, Int#/Int#
-etc.
+Dictionary floating
+~~~~~~~~~~~~~~~~~~~
+Consider this
-Note that specialising an overloaded type at an uboxed type requires
-an unboxed instance -- we cannot default to an unspecialised version!
+ f a (d::Num a) = let g = ...
+ in
+ ...(let d1::Ord a = Num.Ord.sel a d in g a d1)...
+Here, g is only called at one type, but the dictionary isn't in scope at the
+definition point for g. Usually the type checker would build a
+definition for d1 which enclosed g, but the transformation system
+might have moved d1's defn inward. Solution: float dictionary bindings
+outwards along with call instances.
-Dictionary floating
-~~~~~~~~~~~~~~~~~~~
Consider
f x = let g p q = p==q
to widen its scope. Notice that this floating can't be done in advance -- it only
shows up when specialisation is done.
-DELICATE MATTER: the way we tell a dictionary binding is by looking to
-see if it has a Dict type. If the type has been "undictify'd", so that
-it looks like a tuple, then the dictionary binding won't be floated, and
-an opportunity to specialise might be lost.
-
User SPECIALIZE pragmas
~~~~~~~~~~~~~~~~~~~~~~~
Specialisation pragmas can be digested by the type checker, and implemented
The information about what instance of the dfun exist gets added to
the dfun's IdInfo in the same way as a user-defined function too.
-In fact, matters are a little bit more complicated than this.
-When we make one of these specialised instances, we are defining
-a constant dictionary, and so we want immediate access to its constant
-methods and superclasses. Indeed, these constant methods and superclasses
-must be in the IdInfo for the class selectors! We need help from the
-typechecker to sort this out, perhaps by generating a separate IdInfo
-for each.
Automatic instance decl specialisation?
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
new call-instances of the dfuns, and so on. This all arises because of
the unrestricted mutual recursion between instance decls and value decls.
+Still, there's no actual problem; it just means that we may not do all
+the specialisation we could theoretically do.
+
Furthermore, instance decls are usually exported and used non-locally,
so we'll want to compile enough to get those specialisations done.
back in as a pragma when next compiling the file. So for now,
we only specialise instance decls in response to pragmas.
-That means that even if an instance decl ain't otherwise exported it
-needs to be spat out as with a SPECIALIZE pragma. Furthermore, it needs
-something to say which module defined the instance, so the usage info
-can be fed into the right reqts info file. Blegh.
-
-
-SPECIAILISING DATA DECLARATIONS
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-With unboxed specialisation (or full specialisation) we also require
-data types (and their constructors) to be speciailised on unboxed
-type arguments.
-
-In addition to normal call instances we gather TyCon call instances at
-unboxed types, determine equivalence classes for the locally defined
-TyCons and build speciailised data constructor Ids for each TyCon and
-substitute these in the Con calls.
-
-We need the list of local TyCons to partition the TyCon instance info.
-We pass out a FiniteMap from local TyCons to Specialised Instances to
-give to the interface and code genertors.
-
-N.B. The specialised data constructors reference the original data
-constructor and type constructor which do not have the updated
-specialisation info attached. Any specialisation info must be
-extracted from the TyCon map returned.
-
SPITTING OUT USAGE INFORMATION
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
This is done at the top-level when all the call instances which escape
must be for imported functions and data types.
+*** Not currently done ***
+
Partial specialisation by pragmas
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In short, dfun Ids need IdInfo with a specialisation for each
constant instance of their instance declaration.
+All this uses a single mechanism: the SpecEnv inside an Id
+
What does the specialisation IdInfo look like?
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
- SpecInfo
- [Maybe Type] -- Instance types
- Int -- No of dicts to eat
- Id -- Specialised version
+The SpecEnv of an Id maps a list of types (the template) to an expression
+
+ [Type] |-> Expr
For example, if f has this SpecInfo:
- SpecInfo [Just t1, Nothing, Just t3] 2 f'
+ [Int, a] -> \d:Ord Int. f' a
-then
+it means that we can replace the call
- f t1 t2 t3 d1 d2 ===> f t2
+ f Int t ===> (\d. f' t)
+
+This chucks one dictionary away and proceeds with the
+specialised version of f, namely f'.
-The "Nothings" identify type arguments in which the specialised
-version is polymorphic.
What can't be done this way?
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
overloading altogether anyway!
-Mutter mutter
-~~~~~~~~~~~~~
-What about types/classes mentioned in SPECIALIZE pragmas spat out,
-but not otherwise exported. Even if they are exported, what about
-their original names.
-
-Suggestion: use qualified names in pragmas, omitting module for
-prelude and "this module".
-
-
-Mutter mutter 2
-~~~~~~~~~~~~~~~
-Consider this
-
- f a (d::Num a) = let g = ...
- in
- ...(let d1::Ord a = Num.Ord.sel a d in g a d1)...
-
-Here, g is only called at one type, but the dictionary isn't in scope at the
-definition point for g. Usually the type checker would build a
-definition for d1 which enclosed g, but the transformation system
-might have moved d1's defn inward.
-
-
-Unboxed bindings
-~~~~~~~~~~~~~~~~
-
-What should we do when a value is specialised to a *strict* unboxed value?
-
- map_*_* f (x:xs) = let h = f x
- t = map f xs
- in h:t
-
-Could convert let to case:
-
- map_*_Int# f (x:xs) = case f x of h# ->
- let t = map f xs
- in h#:t
-
-This may be undesirable since it forces evaluation here, but the value
-may not be used in all branches of the body. In the general case this
-transformation is impossible since the mutual recursion in a letrec
-cannot be expressed as a case.
-
-There is also a problem with top-level unboxed values, since our
-implementation cannot handle unboxed values at the top level.
-
-Solution: Lift the binding of the unboxed value and extract it when it
-is used:
-
- map_*_Int# f (x:xs) = let h = case (f x) of h# -> _Lift h#
- t = map f xs
- in case h of
- _Lift h# -> h#:t
-
-Now give it to the simplifier and the _Lifting will be optimised away.
-
-The benfit is that we have given the specialised "unboxed" values a
-very simplep lifted semantics and then leave it up to the simplifier to
-optimise it --- knowing that the overheads will be removed in nearly
-all cases.
-
-In particular, the value will only be evaluted in the branches of the
-program which use it, rather than being forced at the point where the
-value is bound. For example:
-
- filtermap_*_* p f (x:xs)
- = let h = f x
- t = ...
- in case p x of
- True -> h:t
- False -> t
- ==>
- filtermap_*_Int# p f (x:xs)
- = let h = case (f x) of h# -> _Lift h#
- t = ...
- in case p x of
- True -> case h of _Lift h#
- -> h#:t
- False -> t
-
-The binding for h can still be inlined in the one branch and the
-_Lifting eliminated.
-
-
-Question: When won't the _Lifting be eliminated?
-
-Answer: When they at the top-level (where it is necessary) or when
-inlining would duplicate work (or possibly code depending on
-options). However, the _Lifting will still be eliminated if the
-strictness analyser deems the lifted binding strict.
-
A note about non-tyvar dictionaries
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
in
returnSM ([], all_uds)
+ | isSpecPragmaId bndr
+ = specExpr rhs `thenSM` \ (rhs', rhs_uds) ->
+ returnSM ([], rhs_uds)
+
| otherwise
= -- Deal with the RHS, specialising it according
-- to the calls found in the body
-- Construct the stuff for f's spec env
-- [b,d] [t1,b,t3,d] |-> \d1 d2 -> f1 b d
+ -- The only awkward bit is that d1,d2 might well be global
+ -- dictionaries, so it's tidier to make new local variables
+ -- for the lambdas in the RHS, rather than lambda-bind the
+ -- dictionaries themselves.
+ mapSM (\d -> newIdSM d (idType d)) call_ds `thenSM` \ arg_ds ->
let
- spec_env_rhs = mkValLam call_ds $
+ spec_env_rhs = mkValLam arg_ds $
mkTyApp (Var spec_f) $
map mkTyVarTy spec_tyvars
spec_env_info = (spec_tyvars, spec_tys, spec_env_rhs)
\end{code}
+ Old (but interesting) stuff about unboxed bindings
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+What should we do when a value is specialised to a *strict* unboxed value?
+
+ map_*_* f (x:xs) = let h = f x
+ t = map f xs
+ in h:t
+
+Could convert let to case:
+
+ map_*_Int# f (x:xs) = case f x of h# ->
+ let t = map f xs
+ in h#:t
+
+This may be undesirable since it forces evaluation here, but the value
+may not be used in all branches of the body. In the general case this
+transformation is impossible since the mutual recursion in a letrec
+cannot be expressed as a case.
+
+There is also a problem with top-level unboxed values, since our
+implementation cannot handle unboxed values at the top level.
+
+Solution: Lift the binding of the unboxed value and extract it when it
+is used:
+
+ map_*_Int# f (x:xs) = let h = case (f x) of h# -> _Lift h#
+ t = map f xs
+ in case h of
+ _Lift h# -> h#:t
+
+Now give it to the simplifier and the _Lifting will be optimised away.
+
+The benfit is that we have given the specialised "unboxed" values a
+very simplep lifted semantics and then leave it up to the simplifier to
+optimise it --- knowing that the overheads will be removed in nearly
+all cases.
+
+In particular, the value will only be evaluted in the branches of the
+program which use it, rather than being forced at the point where the
+value is bound. For example:
+
+ filtermap_*_* p f (x:xs)
+ = let h = f x
+ t = ...
+ in case p x of
+ True -> h:t
+ False -> t
+ ==>
+ filtermap_*_Int# p f (x:xs)
+ = let h = case (f x) of h# -> _Lift h#
+ t = ...
+ in case p x of
+ True -> case h of _Lift h#
+ -> h#:t
+ False -> t
+
+The binding for h can still be inlined in the one branch and the
+_Lifting eliminated.
+
+
+Question: When won't the _Lifting be eliminated?
+
+Answer: When they at the top-level (where it is necessary) or when
+inlining would duplicate work (or possibly code depending on
+options). However, the _Lifting will still be eliminated if the
+strictness analyser deems the lifted binding strict.
+
#include "HsVersions.h"
import {-# SOURCE #-} TcGRHSs ( tcGRHSsAndBinds )
+import {-# SOURCE #-} TcExpr ( tcExpr )
-import HsSyn ( HsBinds(..), MonoBinds(..), Sig(..), InPat(..),
- collectMonoBinders
+import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), InPat(..),
+ collectMonoBinders, andMonoBinds
)
import RnHsSyn ( RenamedHsBinds, RenamedSig(..),
RenamedMonoBinds
newDicts, tyVarsOfInst, instToId, newMethodWithGivenTy,
zonkInst, pprInsts
)
-import TcEnv ( tcExtendLocalValEnv, tcLookupLocalValueOK, newLocalId,
+import TcEnv ( tcExtendLocalValEnv, tcLookupLocalValueOK,
+ newLocalId, newSpecPragmaId,
tcGetGlobalTyVars, tcExtendGlobalTyVars
)
import TcMatches ( tcMatchesFun )
-- should be no black-hole problems here.
-- TYPECHECK THE SIGNATURES
- mapTc (tcTySig prag_info_fn) ty_sigs `thenTc` \ tc_ty_sigs ->
+ mapTc tcTySig ty_sigs `thenTc` \ tc_ty_sigs ->
tcBindWithSigs top_lvl binder_names bind
tc_ty_sigs is_rec prag_info_fn `thenTc` \ (poly_binds, poly_lie, poly_ids) ->
dict_tys = map tcIdType dicts_bound
mk_export binder_name mono_id zonked_mono_id_ty
- | maybeToBool maybe_sig = (sig_tyvars, TcId sig_poly_id, TcId mono_id)
- | otherwise = (real_tyvars_to_gen_list, TcId poly_id, TcId mono_id)
+ = (tyvars, TcId (replaceIdInfo poly_id (prag_info_fn binder_name)), TcId mono_id)
where
- maybe_sig = maybeSig tc_ty_sigs binder_name
- Just (TySigInfo _ sig_poly_id sig_tyvars _ _ _) = maybe_sig
- poly_id = replaceIdInfo (mkUserId binder_name poly_ty) (prag_info_fn binder_name)
- poly_ty = mkForAllTys real_tyvars_to_gen_list $ mkFunTys dict_tys $ zonked_mono_id_ty
+ (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_list, new_poly_id)
+
+ new_poly_id = mkUserId binder_name poly_ty
+ poly_ty = mkForAllTys real_tyvars_to_gen_list $ mkFunTys dict_tys $ zonked_mono_id_ty
-- 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
\begin{code}
-tcTySig :: (Name -> IdInfo)
- -> RenamedSig
+tcTySig :: RenamedSig
-> TcM s (TcSigInfo s)
-tcTySig prag_info_fn (Sig v ty src_loc)
+tcTySig (Sig v ty src_loc)
= tcAddSrcLoc src_loc $
tcHsType ty `thenTc` \ sigma_ty ->
-- Convert from Type to TcType
tcInstSigType sigma_ty `thenNF_Tc` \ sigma_tc_ty ->
let
- poly_id = replaceIdInfo (mkUserId v sigma_tc_ty) (prag_info_fn v)
+ poly_id = mkUserId v sigma_tc_ty
in
-- Instantiate this type
-- It's important to do this even though in the error-free case
TcMonoBinds s,
LIE s)
--- For now we just deal with INLINE pragmas
-tcPragmaSigs sigs = returnTc (prag_fn, EmptyMonoBinds, emptyLIE )
- where
- prag_fn name = info
- where
- info | any has_inline sigs = IWantToBeINLINEd `setInlinePragInfo` noIdInfo
- | otherwise = noIdInfo
-
- has_inline (InlineSig n _) = (n == name)
- has_inline other = False
+tcPragmaSigs sigs
+ = mapAndUnzip3Tc tcPragmaSig sigs `thenTc` \ (maybe_info_modifiers, binds, lies) ->
+ let
+ prag_fn name = foldr ($) noIdInfo [f | Just (n,f) <- maybe_info_modifiers, n==name]
+ in
+ returnTc (prag_fn, andMonoBinds binds, plusLIEs lies)
\end{code}
The interesting case is for SPECIALISE pragmas. There are two forms.
a bit of overkill.
\begin{code}
-{-
-tcPragmaSig :: RenamedSig -> TcM s ((Name, IdInfo -> IdInfo), TcMonoBinds s, LIE s)
+tcPragmaSig :: RenamedSig -> TcM s (Maybe (Name, IdInfo -> IdInfo), TcMonoBinds s, LIE s)
+tcPragmaSig (Sig _ _ _) = returnTc (Nothing, EmptyMonoBinds, emptyLIE)
+tcPragmaSig (SpecInstSig _ _) = returnTc (Nothing, EmptyMonoBinds, emptyLIE)
+
tcPragmaSig (InlineSig name loc)
- = returnTc ((name, setInlinePragInfo IdWantsToBeINLINEd), EmptyBinds, emptyLIE)
+ = returnTc (Just (name, setInlinePragInfo IWantToBeINLINEd), EmptyMonoBinds, emptyLIE)
tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc)
- = tcAddSrcLoc src_loc $
- tcAddErrCtxt (valSpecSigCtxt name spec_ty) $
+ = -- SPECIALISE f :: forall b. theta => tau = g
+ tcAddSrcLoc src_loc $
+ tcAddErrCtxt (valSpecSigCtxt name poly_ty) $
-- Get and instantiate its alleged specialised type
tcHsType poly_ty `thenTc` \ sig_sigma ->
tcInstSigType sig_sigma `thenNF_Tc` \ sig_ty ->
- -- Typecheck the RHS
- -- f :: sig_ty
- tcPolyExpr str (Var name) sig_ty `thenTc` \ (rhs, lie) ->
-
- -- If this succeeds, then the signature is indeed less general
- -- than the main function
- let
- (tyvars, tys, template)
- = case rhs of
- TyLam tyvars (DictLam dicts (HsLet (MonoBind dict_binds
-we can take apart the RHS,
- -- which will be of very specific form
-
-
- tcLookupLocalValueOK "tcPragmaSig" name `thenNF_Tc` \ main_id ->
-
- -- Check that the specialised signature is an instance
- -- of the
- let
- rhs_name = case maybe_spec_name of
- Just name -> name
- other -> name
- in
-
- -- Build the SpecPragmaId; it is the thing that makes sure we
- -- don't prematurely dead-code-eliminate the binding we are really interested in.
- newSpecPragmaId name sig_ty `thenNF_Tc` \ spec_id ->
-
- returnTc ((name, ...),
- VarMonoBind spec_id rhs,
- lie)
--}
+ -- Check that f has a more general type, and build a RHS for
+ -- the spec-pragma-id at the same time
+ tcExpr (HsVar name) sig_ty `thenTc` \ (spec_expr, spec_lie) ->
+
+ case maybe_spec_name of
+ Nothing -> -- Just specialise "f" by building a pecPragmaId binding
+ -- It is the thing that makes sure we don't prematurely
+ -- dead-code-eliminate the binding we are really interested in.
+ newSpecPragmaId name sig_ty `thenNF_Tc` \ spec_id ->
+ returnTc (Nothing, VarMonoBind (TcId spec_id) spec_expr, spec_lie)
+
+ Just g_name -> -- Don't create a SpecPragmaId. Instead add some suitable IdIfo
+
+ panic "Can't handle SPECIALISE with a '= g' part"
+
+ {- Not yet. Because we're still in the TcType world we
+ can't really add to the SpecEnv of the Id. Instead we have to
+ record the information in a different sort of Sig, and add it to
+ the IdInfo after zonking.
+
+ For now we just leave out this case
+
+ -- Get the type of f, and find out what types
+ -- f has to be instantiated at to give the signature type
+ tcLookupLocalValueOK "tcPragmaSig" name `thenNF_Tc` \ f_id ->
+ tcInstSigTcType (idType f_id) `thenNF_Tc` \ (f_tyvars, f_rho) ->
+
+ let
+ (sig_tyvars, sig_theta, sig_tau) = splitSigmaTy sig_ty
+ (f_theta, f_tau) = splitRhoTy f_rho
+ sig_tyvar_set = mkTyVarSet sig_tyvars
+ in
+ unifyTauTy sig_tau f_tau `thenTc_`
+
+ tcPolyExpr str (HsVar g_name) (mkSigmaTy sig_tyvars f_theta sig_tau) `thenTc` \ (_, _,
+ -}
+
+tcPragmaSig other = pprTrace "tcPragmaSig: ignoring" (ppr other) $
+ returnTc (Nothing, EmptyMonoBinds, emptyLIE)
\end{code}
import BasicTypes ( NewOrData(..), TopLevelFlag(..), RecFlag(..) )
import RnHsSyn ( RenamedClassDecl(..), RenamedClassPragmas(..),
RenamedClassOpSig(..), RenamedMonoBinds,
- RenamedContext(..), RenamedHsDecl
+ RenamedContext(..), RenamedHsDecl, RenamedSig
)
import TcHsSyn ( TcMonoBinds )
import Inst ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, newDicts, newMethod )
import TcEnv ( TcIdOcc(..), tcAddImportedIdInfo,
tcLookupClass, tcLookupTyVar,
- tcExtendGlobalTyVars )
-import TcBinds ( tcBindWithSigs, checkSigTyVars, sigCtxt, TcSigInfo(..) )
+ tcExtendGlobalTyVars, tcExtendLocalValEnv
+ )
+import TcBinds ( tcBindWithSigs, checkSigTyVars, sigCtxt, tcPragmaSigs, TcSigInfo(..) )
import TcKind ( unifyKinds, TcKind )
import TcMonad
import TcMonoType ( tcHsType, tcContext )
| otherwise
= -- Normal case
- tcMethodBind clas origin inst_tys clas_tyvars sel_id meth_bind
+ tcMethodBind clas origin inst_tys clas_tyvars sel_id meth_bind [{- No prags -}]
`thenTc` \ (bind, insts, (_, local_dm_id)) ->
returnTc (bind, insts, (clas_tyvars, RealId dm_id, local_dm_id))
where
-- want to check that they don't bound
-> Id -- The method selector
-> RenamedMonoBinds -- Method binding (just one)
+ -> [RenamedSig] -- Pramgas (just for this one)
-> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s))
-tcMethodBind clas origin inst_tys inst_tyvars sel_id meth_bind
+tcMethodBind clas origin inst_tys inst_tyvars sel_id meth_bind prags
= tcAddSrcLoc src_loc $
newMethod origin (RealId sel_id) inst_tys `thenNF_Tc` \ meth@(_, TcId local_meth_id) ->
tcInstSigTcType (idType local_meth_id) `thenNF_Tc` \ (tyvars', rho_ty') ->
(theta', tau') = splitRhoTy rho_ty'
sig_info = TySigInfo bndr_name local_meth_id tyvars' theta' tau' src_loc
in
+ tcExtendLocalValEnv [bndr_name] [local_meth_id] (
+ tcPragmaSigs prags
+ ) `thenTc` \ (prag_info_fn, prag_binds, prag_lie) ->
+
tcExtendGlobalTyVars inst_tyvars (
tcAddErrCtxt (methodCtxt sel_id) $
tcBindWithSigs NotTopLevel [bndr_name] meth_bind [sig_info]
- NonRecursive (\_ -> noIdInfo)
+ NonRecursive prag_info_fn
) `thenTc` \ (binds, insts, _) ->
-- Now check that the instance type variables
checkSigTyVars inst_tyvars (idType local_meth_id)
) `thenTc_`
- returnTc (binds, insts, meth)
+ returnTc (binds `AndMonoBinds` prag_binds,
+ insts `plusLIE` prag_lie,
+ meth)
where
(bndr_name, src_loc) = case meth_bind of
FunMonoBind name _ _ loc -> (name, loc)
tcAddImportedIdInfo, tcExplicitLookupGlobal,
tcLookupGlobalValueByKeyMaybe,
- newMonoIds, newLocalIds, newLocalId,
+ newMonoIds, newLocalIds, newLocalId, newSpecPragmaId,
tcGetGlobalTyVars, tcExtendGlobalTyVars
) where
#include "HsVersions.h"
-import MkId ( mkUserLocal, mkUserId )
+import MkId ( mkUserLocal, mkUserId, mkSpecPragmaId )
import Id ( Id, GenId, idType, replaceIdInfo, idInfo )
import TcKind ( TcKind, kindToTcKind, Kind )
import TcType ( TcType, TcMaybe, TcTyVar, TcTyVarSet, TcThetaType,
import TcMonad
import IdInfo ( noIdInfo )
-import Name ( Name, OccName(..),
+import Name ( Name, OccName(..), nameOccName,
maybeWiredInTyConName, maybeWiredInIdName, isLocallyDefined,
NamedThing(..)
)
mk_id name uniq ty = mkUserLocal name uniq ty loc
in
returnNF_Tc new_ids
+
+newSpecPragmaId :: Name -> TcType s -> NF_TcM s (TcIdBndr s)
+newSpecPragmaId name ty
+ = tcGetSrcLoc `thenNF_Tc` \ loc ->
+ tcGetUnique `thenNF_Tc` \ uniq ->
+ returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty loc)
\end{code}
\section[TcExpr]{Typecheck an expression}
\begin{code}
-module TcExpr ( tcExpr, tcStmt, tcId ) where
+module TcExpr ( tcExpr, tcId ) where
#include "HsVersions.h"
tcLookupTyCon
)
import TcMatches ( tcMatchesCase, tcMatchExpected )
+import TcGRHSs ( tcStmt )
import TcMonoType ( tcHsType )
import TcPat ( tcPat )
import TcSimplify ( tcSimplifyAndCheck )
-import TcType ( TcType, TcMaybe(..),
+import TcType ( TcType, TcTauType, TcMaybe(..),
tcInstType, tcInstSigTcType, tcInstTyVars,
tcInstSigType, tcInstTcType, tcInstTheta, tcSplitRhoTy,
newTyVarTy, newTyVarTys, zonkTcType )
mkTyConApp,
splitForAllTys, splitRhoTy, splitSigmaTy,
isTauTy, tyVarsOfType, tyVarsOfTypes,
- splitForAllTy_maybe, splitAlgTyConApp, splitAlgTyConApp_maybe
+ isForAllTy, splitAlgTyConApp, splitAlgTyConApp_maybe
)
import TyVar ( emptyTyVarEnv, zipTyVarEnv,
elementOfTyVarSet, mkTyVarSet, tyVarSetToList
import Util
\end{code}
+%************************************************************************
+%* *
+\subsection{Main wrappers}
+%* *
+%************************************************************************
+
\begin{code}
-tcExpr :: RenamedHsExpr -- Expession to type check
- -> TcType s -- Expected type (could be a type variable)
- -> TcM s (TcExpr s, LIE s)
+tcExpr :: RenamedHsExpr -- Expession to type check
+ -> TcType s -- Expected type (could be a polytpye)
+ -> TcM s (TcExpr s, LIE s)
+
+tcExpr expr ty | isForAllTy ty = -- Polymorphic case
+ tcPolyExpr expr ty `thenTc` \ (expr', lie, _, _, _) ->
+ returnTc (expr', lie)
+
+ | otherwise = -- Monomorphic case
+ tcMonoExpr expr ty
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{@tcPolyExpr@ typchecks an application}
+%* *
+%************************************************************************
+
+\begin{code}
+-- tcPolyExpr is like tcMonoExpr, except that the expected type
+-- can be a polymorphic one.
+tcPolyExpr :: RenamedHsExpr
+ -> TcType s -- Expected type
+ -> TcM s (TcExpr s, LIE s, -- Generalised expr with expected type, and LIE
+ TcExpr s, TcTauType s, LIE s) -- Same thing, but instantiated; tau-type returned
+
+tcPolyExpr arg expected_arg_ty
+ = -- Ha! The argument type of the function is a for-all type,
+ -- An example of rank-2 polymorphism.
+
+ -- To ensure that the forall'd type variables don't get unified with each
+ -- other or any other types, we make fresh copy of the alleged type
+ tcInstSigTcType expected_arg_ty `thenNF_Tc` \ (sig_tyvars, sig_rho) ->
+ let
+ (sig_theta, sig_tau) = splitRhoTy sig_rho
+ in
+ -- Type-check the arg and unify with expected type
+ tcExtendGlobalTyVars sig_tyvars (
+ tcMonoExpr arg sig_tau
+ ) `thenTc` \ (arg', lie_arg) ->
+
+ -- Check that the arg_tyvars havn't been constrained
+ -- The interesting bit here is that we must include the free variables
+ -- of the expected arg ty. Here's an example:
+ -- runST (newVar True)
+ -- Here, if we don't make a check, we'll get a type (ST s (MutVar s Bool))
+ -- for (newVar True), with s fresh. Then we unify with the runST's arg type
+ -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool.
+ -- So now s' isn't unconstrained because it's linked to a.
+ -- Conclusion: include the free vars of the expected arg type in the
+ -- list of "free vars" for the signature check.
+
+ tcExtendGlobalTyVars (tyVarSetToList (tyVarsOfType expected_arg_ty)) $
+
+ checkSigTyVars sig_tyvars sig_tau `thenTc` \ zonked_sig_tyvars ->
+ newDicts SignatureOrigin sig_theta `thenNF_Tc` \ (sig_dicts, dict_ids) ->
+ -- ToDo: better origin
+
+ tcSimplifyAndCheck
+ (text "tcPolyExpr")
+ (mkTyVarSet zonked_sig_tyvars)
+ sig_dicts lie_arg `thenTc` \ (free_insts, inst_binds) ->
+
+ let
+ -- This HsLet binds any Insts which came out of the simplification.
+ -- It's a bit out of place here, but using AbsBind involves inventing
+ -- a couple of new names which seems worse.
+ generalised_arg = TyLam zonked_sig_tyvars $
+ DictLam dict_ids $
+ HsLet (MonoBind inst_binds [] Recursive)
+ arg'
+ in
+ returnTc ( generalised_arg, free_insts,
+ arg', sig_tau, lie_arg )
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-tcExpr (HsVar name) res_ty
+tcMonoExpr :: RenamedHsExpr -- Expession to type check
+ -> TcTauType s -- Expected type (could be a type variable)
+ -> TcM s (TcExpr s, LIE s)
+
+tcMonoExpr (HsVar name) res_ty
= tcId name `thenNF_Tc` \ (expr', lie, id_ty) ->
unifyTauTy res_ty id_ty `thenTc_`
Overloaded literals.
\begin{code}
-tcExpr (HsLit (HsInt i)) res_ty
+tcMonoExpr (HsLit (HsInt i)) res_ty
= newOverloadedLit (LiteralOrigin (HsInt i))
(OverloadedIntegral i)
res_ty `thenNF_Tc` \ stuff ->
returnTc stuff
-tcExpr (HsLit (HsFrac f)) res_ty
+tcMonoExpr (HsLit (HsFrac f)) res_ty
= newOverloadedLit (LiteralOrigin (HsFrac f))
(OverloadedFractional f)
res_ty `thenNF_Tc` \ stuff ->
returnTc stuff
-tcExpr (HsLit lit@(HsLitLit s)) res_ty
+tcMonoExpr (HsLit lit@(HsLitLit s)) res_ty
= tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass ->
newDicts (LitLitOrigin (_UNPK_ s))
[(cCallableClass, [res_ty])] `thenNF_Tc` \ (dicts, _) ->
Primitive literals:
\begin{code}
-tcExpr (HsLit lit@(HsCharPrim c)) res_ty
+tcMonoExpr (HsLit lit@(HsCharPrim c)) res_ty
= unifyTauTy res_ty charPrimTy `thenTc_`
returnTc (HsLitOut lit charPrimTy, emptyLIE)
-tcExpr (HsLit lit@(HsStringPrim s)) res_ty
+tcMonoExpr (HsLit lit@(HsStringPrim s)) res_ty
= unifyTauTy res_ty addrPrimTy `thenTc_`
returnTc (HsLitOut lit addrPrimTy, emptyLIE)
-tcExpr (HsLit lit@(HsIntPrim i)) res_ty
+tcMonoExpr (HsLit lit@(HsIntPrim i)) res_ty
= unifyTauTy res_ty intPrimTy `thenTc_`
returnTc (HsLitOut lit intPrimTy, emptyLIE)
-tcExpr (HsLit lit@(HsFloatPrim f)) res_ty
+tcMonoExpr (HsLit lit@(HsFloatPrim f)) res_ty
= unifyTauTy res_ty floatPrimTy `thenTc_`
returnTc (HsLitOut lit floatPrimTy, emptyLIE)
-tcExpr (HsLit lit@(HsDoublePrim d)) res_ty
+tcMonoExpr (HsLit lit@(HsDoublePrim d)) res_ty
= unifyTauTy res_ty doublePrimTy `thenTc_`
returnTc (HsLitOut lit doublePrimTy, emptyLIE)
\end{code}
Unoverloaded literals:
\begin{code}
-tcExpr (HsLit lit@(HsChar c)) res_ty
+tcMonoExpr (HsLit lit@(HsChar c)) res_ty
= unifyTauTy res_ty charTy `thenTc_`
returnTc (HsLitOut lit charTy, emptyLIE)
-tcExpr (HsLit lit@(HsString str)) res_ty
+tcMonoExpr (HsLit lit@(HsString str)) res_ty
= unifyTauTy res_ty stringTy `thenTc_`
returnTc (HsLitOut lit stringTy, emptyLIE)
\end{code}
%************************************************************************
\begin{code}
-tcExpr (HsPar expr) res_ty -- preserve parens so printing needn't guess where they go
- = tcExpr expr res_ty
+tcMonoExpr (HsPar expr) res_ty -- preserve parens so printing needn't guess where they go
+ = tcMonoExpr expr res_ty
-- perform the negate *before* overloading the integer, since the case
-- of minBound on Ints fails otherwise. Could be done elsewhere, but
-- convenient to do it here.
-tcExpr (NegApp (HsLit (HsInt i)) neg) res_ty
- = tcExpr (HsLit (HsInt (-i))) res_ty
+tcMonoExpr (NegApp (HsLit (HsInt i)) neg) res_ty
+ = tcMonoExpr (HsLit (HsInt (-i))) res_ty
-tcExpr (NegApp expr neg) res_ty
- = tcExpr (HsApp neg expr) res_ty
+tcMonoExpr (NegApp expr neg) res_ty
+ = tcMonoExpr (HsApp neg expr) res_ty
-tcExpr (HsLam match) res_ty
+tcMonoExpr (HsLam match) res_ty
= tcMatchExpected [] res_ty match `thenTc` \ (match',lie) ->
returnTc (HsLam match', lie)
-tcExpr (HsApp e1 e2) res_ty = accum e1 [e2]
+tcMonoExpr (HsApp e1 e2) res_ty = accum e1 [e2]
where
accum (HsApp e1 e2) args = accum e1 (e2:args)
accum fun args
returnTc (foldl HsApp fun' args', lie)
-- equivalent to (op e1) e2:
-tcExpr (OpApp arg1 op fix arg2) res_ty
+tcMonoExpr (OpApp arg1 op fix arg2) res_ty
= tcApp op [arg1,arg2] res_ty `thenTc` \ (op', [arg1', arg2'], lie) ->
returnTc (OpApp arg1' op' fix arg2', lie)
\end{code}
-- or just
-- op e
-tcExpr in_expr@(SectionL arg op) res_ty
+tcMonoExpr in_expr@(SectionL arg op) res_ty
= tcApp op [arg] res_ty `thenTc` \ (op', [arg'], lie) ->
-- Check that res_ty is a function type
-- Right sections, equivalent to \ x -> x op expr, or
-- \ x -> op x expr
-tcExpr in_expr@(SectionR op expr) res_ty
+tcMonoExpr in_expr@(SectionR op expr) res_ty
= tcExpr_id op `thenTc` \ (op', lie1, op_ty) ->
tcAddErrCtxt (sectionRAppCtxt in_expr) $
split_fun_ty op_ty 2 {- two args -} `thenTc` \ ([arg1_ty, arg2_ty], op_res_ty) ->
- tcExpr expr arg2_ty `thenTc` \ (expr',lie2) ->
+ tcMonoExpr expr arg2_ty `thenTc` \ (expr',lie2) ->
unifyTauTy res_ty (mkFunTy arg1_ty op_res_ty) `thenTc_`
returnTc (SectionR op' expr', lie1 `plusLIE` lie2)
\end{code}
later use.
\begin{code}
-tcExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty
+tcMonoExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty
= -- Get the callable and returnable classes.
tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass ->
tcLookupClassByKey cReturnableClassKey `thenNF_Tc` \ cReturnableClass ->
-- Arguments
mapNF_Tc (\ _ -> newTyVarTy mkTypeKind) [1..(length args)] `thenNF_Tc` \ ty_vars ->
- tcExprs args ty_vars `thenTc` \ (args', args_lie) ->
+ tcMonoExprs args ty_vars `thenTc` \ (args', args_lie) ->
-- The argument types can be unboxed or boxed; the result
-- type must, however, be boxed since it's an argument to the IO
-- Construct the extra insts, which encode the
-- constraints on the argument and result types.
- mapNF_Tc new_arg_dict (zipEqual "tcExpr:CCall" args ty_vars) `thenNF_Tc` \ ccarg_dicts_s ->
+ mapNF_Tc new_arg_dict (zipEqual "tcMonoExpr:CCall" args ty_vars) `thenNF_Tc` \ ccarg_dicts_s ->
newDicts result_origin [(cReturnableClass, [result_ty])] `thenNF_Tc` \ (ccres_dict, _) ->
returnTc (HsApp (HsVar (RealId ioDataCon) `TyApp` [result_ty])
\end{code}
\begin{code}
-tcExpr (HsSCC label expr) res_ty
- = tcExpr expr res_ty `thenTc` \ (expr', lie) ->
+tcMonoExpr (HsSCC label expr) res_ty
+ = tcMonoExpr expr res_ty `thenTc` \ (expr', lie) ->
returnTc (HsSCC label expr', lie)
-tcExpr (HsLet binds expr) res_ty
+tcMonoExpr (HsLet binds expr) res_ty
= tcBindsAndThen
combiner
binds -- Bindings to check
- (tc_expr) `thenTc` \ (expr', lie) ->
+ tc_expr `thenTc` \ (expr', lie) ->
returnTc (expr', lie)
where
- tc_expr = tcExpr expr res_ty `thenTc` \ (expr', lie) ->
+ tc_expr = tcMonoExpr expr res_ty `thenTc` \ (expr', lie) ->
returnTc (expr', lie)
combiner is_rec bind expr = HsLet (MonoBind bind [] is_rec) expr
-tcExpr in_expr@(HsCase scrut matches src_loc) res_ty
+tcMonoExpr in_expr@(HsCase scrut matches src_loc) res_ty
= tcAddSrcLoc src_loc $
tcAddErrCtxt (caseCtxt in_expr) $
tcMatchesCase res_ty matches `thenTc` \ (scrut_ty, matches', lie2) ->
tcAddErrCtxt (caseScrutCtxt scrut) (
- tcExpr scrut scrut_ty
+ tcMonoExpr scrut scrut_ty
) `thenTc` \ (scrut',lie1) ->
returnTc (HsCase scrut' matches' src_loc, plusLIE lie1 lie2)
-tcExpr (HsIf pred b1 b2 src_loc) res_ty
+tcMonoExpr (HsIf pred b1 b2 src_loc) res_ty
= tcAddSrcLoc src_loc $
tcAddErrCtxt (predCtxt pred) (
- tcExpr pred boolTy ) `thenTc` \ (pred',lie1) ->
+ tcMonoExpr pred boolTy ) `thenTc` \ (pred',lie1) ->
- tcExpr b1 res_ty `thenTc` \ (b1',lie2) ->
- tcExpr b2 res_ty `thenTc` \ (b2',lie3) ->
+ tcMonoExpr b1 res_ty `thenTc` \ (b1',lie2) ->
+ tcMonoExpr b2 res_ty `thenTc` \ (b2',lie3) ->
returnTc (HsIf pred' b1' b2' src_loc, plusLIE lie1 (plusLIE lie2 lie3))
\end{code}
\begin{code}
-tcExpr expr@(HsDo do_or_lc stmts src_loc) res_ty
+tcMonoExpr expr@(HsDo do_or_lc stmts src_loc) res_ty
= tcDoStmts do_or_lc stmts src_loc res_ty
\end{code}
\begin{code}
-tcExpr in_expr@(ExplicitList exprs) res_ty -- Non-empty list
+tcMonoExpr in_expr@(ExplicitList exprs) res_ty -- Non-empty list
= unifyListTy res_ty `thenTc` \ elt_ty ->
mapAndUnzipTc (tc_elt elt_ty) exprs `thenTc` \ (exprs', lies) ->
returnTc (ExplicitListOut elt_ty exprs', plusLIEs lies)
where
tc_elt elt_ty expr
= tcAddErrCtxt (listCtxt expr) $
- tcExpr expr elt_ty
+ tcMonoExpr expr elt_ty
-tcExpr (ExplicitTuple exprs) res_ty
+tcMonoExpr (ExplicitTuple exprs) res_ty
= unifyTupleTy (length exprs) res_ty `thenTc` \ arg_tys ->
- mapAndUnzipTc (\ (expr, arg_ty) -> tcExpr expr arg_ty)
+ mapAndUnzipTc (\ (expr, arg_ty) -> tcMonoExpr expr arg_ty)
(exprs `zip` arg_tys) -- we know they're of equal length.
`thenTc` \ (exprs', lies) ->
returnTc (ExplicitTuple exprs', plusLIEs lies)
-tcExpr (RecordCon con_name _ rbinds) res_ty
+tcMonoExpr (RecordCon con_name _ rbinds) res_ty
= tcLookupGlobalValue con_name `thenNF_Tc` \ con_id ->
tcId con_name `thenNF_Tc` \ (con_expr, con_lie, con_tau) ->
let
--
-- All this is done in STEP 4 below.
-tcExpr (RecordUpd record_expr rbinds) res_ty
+tcMonoExpr (RecordUpd record_expr rbinds) res_ty
= tcAddErrCtxt recordUpdCtxt $
-- STEP 1
let
record_ty = mkTyConApp tycon inst_tys
in
- tcExpr record_expr record_ty `thenTc` \ (record_expr', record_lie) ->
+ tcMonoExpr record_expr record_ty `thenTc` \ (record_expr', record_lie) ->
-- STEP 6
-- Figure out the LIE we need. We have to generate some
returnTc (RecordUpdOut record_expr' result_record_ty dicts rbinds',
con_lie `plusLIE` record_lie `plusLIE` rbinds_lie)
-tcExpr (ArithSeqIn seq@(From expr)) res_ty
+tcMonoExpr (ArithSeqIn seq@(From expr)) res_ty
= unifyListTy res_ty `thenTc` \ elt_ty ->
- tcExpr expr elt_ty `thenTc` \ (expr', lie1) ->
+ tcMonoExpr expr elt_ty `thenTc` \ (expr', lie1) ->
tcLookupGlobalValueByKey enumFromClassOpKey `thenNF_Tc` \ sel_id ->
newMethod (ArithSeqOrigin seq)
returnTc (ArithSeqOut (HsVar enum_from_id) (From expr'),
lie1 `plusLIE` lie2)
-tcExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2)) res_ty
+tcMonoExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2)) res_ty
= tcAddErrCtxt (arithSeqCtxt in_expr) $
unifyListTy res_ty `thenTc` \ elt_ty ->
- tcExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
- tcExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
+ tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
+ tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
tcLookupGlobalValueByKey enumFromThenClassOpKey `thenNF_Tc` \ sel_id ->
newMethod (ArithSeqOrigin seq)
(RealId sel_id) [elt_ty] `thenNF_Tc` \ (lie3, enum_from_then_id) ->
(FromThen expr1' expr2'),
lie1 `plusLIE` lie2 `plusLIE` lie3)
-tcExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2)) res_ty
+tcMonoExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2)) res_ty
= tcAddErrCtxt (arithSeqCtxt in_expr) $
unifyListTy res_ty `thenTc` \ elt_ty ->
- tcExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
- tcExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
+ tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
+ tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
tcLookupGlobalValueByKey enumFromToClassOpKey `thenNF_Tc` \ sel_id ->
newMethod (ArithSeqOrigin seq)
(RealId sel_id) [elt_ty] `thenNF_Tc` \ (lie3, enum_from_to_id) ->
(FromTo expr1' expr2'),
lie1 `plusLIE` lie2 `plusLIE` lie3)
-tcExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty
+tcMonoExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty
= tcAddErrCtxt (arithSeqCtxt in_expr) $
unifyListTy res_ty `thenTc` \ elt_ty ->
- tcExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
- tcExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
- tcExpr expr3 elt_ty `thenTc` \ (expr3',lie3) ->
+ tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) ->
+ tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) ->
+ tcMonoExpr expr3 elt_ty `thenTc` \ (expr3',lie3) ->
tcLookupGlobalValueByKey enumFromThenToClassOpKey `thenNF_Tc` \ sel_id ->
newMethod (ArithSeqOrigin seq)
(RealId sel_id) [elt_ty] `thenNF_Tc` \ (lie4, eft_id) ->
%************************************************************************
\begin{code}
-tcExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
+tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
= tcSetErrCtxt (exprSigCtxt in_expr) $
- tcHsType poly_ty `thenTc` \ sigma_sig ->
-
- -- Check the tau-type part
- tcInstSigType sigma_sig `thenNF_Tc` \ sigma_sig' ->
- let
- (sig_tyvars', sig_theta', sig_tau') = splitSigmaTy sigma_sig'
- in
-
- -- Type check the expression, expecting the signature type
- tcExtendGlobalTyVars sig_tyvars' (
- tcExpr expr sig_tau'
- ) `thenTc` \ (texpr, lie) ->
-
- -- Check the type variables of the signature,
- -- *after* typechecking the expression
- checkSigTyVars sig_tyvars' sig_tau' `thenTc` \ zonked_sig_tyvars ->
-
- -- Check overloading constraints
- newDicts SignatureOrigin sig_theta' `thenNF_Tc` \ (sig_dicts, _) ->
- tcSimplifyAndCheck
- (ptext SLIT("the type signature") <+> quotes (ppr sigma_sig))
- (mkTyVarSet zonked_sig_tyvars)
- sig_dicts lie
- `thenTc_`
-
- -- Now match the signature type with res_ty.
- -- We must not do this earlier, because res_ty might well
- -- mention variables free in the environment, and we'd get
- -- bogus complaints about not being able to for-all the
- -- sig_tyvars
- unifyTauTy res_ty sig_tau' `thenTc_`
-
- -- If everything is ok, return the stuff unchanged, except for
- -- the effect of any substutions etc. We simply discard the
- -- result of the tcSimplifyAndCheck, except for any default
- -- resolution it may have done, which is recorded in the
- -- substitution.
- returnTc (texpr, lie)
-
+ tcHsType poly_ty `thenTc` \ sig_ty ->
+ tcInstSigType sig_ty `thenNF_Tc` \ sig_tc_ty ->
+
+ if not (isForAllTy sig_tc_ty) then
+ -- Easy case
+ unifyTauTy sig_tc_ty res_ty `thenTc_`
+ tcMonoExpr expr sig_tc_ty
+
+ else -- Signature is polymorphic
+ tcPolyExpr in_expr sig_tc_ty `thenTc` \ (_, _, expr, expr_ty, lie) ->
+
+ -- Now match the signature type with res_ty.
+ -- We must not do this earlier, because res_ty might well
+ -- mention variables free in the environment, and we'd get
+ -- bogus complaints about not being able to for-all the
+ -- sig_tyvars
+ unifyTauTy res_ty expr_ty `thenTc_`
+
+ -- If everything is ok, return the stuff unchanged, except for
+ -- the effect of any substutions etc. We simply discard the
+ -- result of the tcSimplifyAndCheck (inside tcPolyExpr), except for any default
+ -- resolution it may have done, which is recorded in the
+ -- substitution.
+ returnTc (expr, lie)
\end{code}
Typecheck expression which in most cases will be an Id.
HsVar name -> tcId name `thenNF_Tc` \ stuff ->
returnTc stuff
other -> newTyVarTy mkTypeKind `thenNF_Tc` \ id_ty ->
- tcExpr id_expr id_ty `thenTc` \ (id_expr', lie_id) ->
+ tcMonoExpr id_expr id_ty `thenTc` \ (id_expr', lie_id) ->
returnTc (id_expr', lie_id, id_ty)
\end{code}
tcArg the_fun (arg, expected_arg_ty, arg_no)
= tcAddErrCtxt (funAppCtxt the_fun arg arg_no) $
- tcPolyExpr (ptext SLIT("argument type of") <+> quotes (ppr the_fun))
- arg expected_arg_ty
-
-
--- tcPolyExpr is like tcExpr, except that the expected type
--- can be a polymorphic one.
-tcPolyExpr :: SDoc -- Just for error messages
- -> RenamedHsExpr
- -> TcType s -- Expected type
- -> TcM s (TcExpr s, LIE s) -- Resulting type and LIE
-
-tcPolyExpr str arg expected_arg_ty
- | not (maybeToBool (splitForAllTy_maybe expected_arg_ty))
- = -- The ordinary, non-rank-2 polymorphic case
tcExpr arg expected_arg_ty
-
- | otherwise
- = -- Ha! The argument type of the function is a for-all type,
- -- An example of rank-2 polymorphism.
-
- -- No need to instantiate the argument type... it's must be the result
- -- of instantiating a function involving rank-2 polymorphism, so there
- -- isn't any danger of using the same tyvars twice
- -- The argument type shouldn't be overloaded type (hence ASSERT)
-
- -- To ensure that the forall'd type variables don't get unified with each
- -- other or any other types, we make fresh *signature* type variables
- -- and unify them with the tyvars.
- tcInstSigTcType expected_arg_ty `thenNF_Tc` \ (sig_tyvars, sig_rho) ->
- let
- (sig_theta, sig_tau) = splitRhoTy sig_rho
- in
- -- Type-check the arg and unify with expected type
- tcExpr arg sig_tau `thenTc` \ (arg', lie_arg) ->
-
- -- Check that the arg_tyvars havn't been constrained
- -- The interesting bit here is that we must include the free variables
- -- of the expected arg ty. Here's an example:
- -- runST (newVar True)
- -- Here, if we don't make a check, we'll get a type (ST s (MutVar s Bool))
- -- for (newVar True), with s fresh. Then we unify with the runST's arg type
- -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool.
- -- So now s' isn't unconstrained because it's linked to a.
- -- Conclusion: include the free vars of the expected arg type in the
- -- list of "free vars" for the signature check.
-
- tcExtendGlobalTyVars (tyVarSetToList (tyVarsOfType expected_arg_ty)) $
-
- checkSigTyVars sig_tyvars sig_tau `thenTc` \ zonked_sig_tyvars ->
- newDicts SignatureOrigin sig_theta `thenNF_Tc` \ (sig_dicts, dict_ids) ->
- -- ToDo: better origin
-
- tcSimplifyAndCheck
- str
- (mkTyVarSet zonked_sig_tyvars)
- sig_dicts lie_arg `thenTc` \ (free_insts, inst_binds) ->
-
- -- This HsLet binds any Insts which came out of the simplification.
- -- It's a bit out of place here, but using AbsBind involves inventing
- -- a couple of new names which seems worse.
- returnTc ( TyLam zonked_sig_tyvars $
- DictLam dict_ids $
- HsLet (MonoBind inst_binds [] Recursive)
- arg'
- , free_insts
- )
\end{code}
+
%************************************************************************
%* *
\subsection{@tcId@ typchecks an identifier occurrence}
let
tc_stmts [] = returnTc (([], error "tc_stmts"), emptyLIE)
- tc_stmts (stmt:stmts) = tcStmt tcExpr do_or_lc (mkAppTy m) combine_stmts stmt $
+ tc_stmts (stmt:stmts) = tcStmt do_or_lc (mkAppTy m) combine_stmts stmt $
tc_stmts stmts
combine_stmts stmt@(ReturnStmt _) (Just ty) ([], _) = ([stmt], ty)
\end{code}
-\begin{code}
-tcStmt :: (RenamedHsExpr -> TcType s -> TcM s (TcExpr s, LIE s)) -- This is tcExpr
- -- The sole, disgusting, reason for this parameter
- -- is to get the effect of polymorphic recursion
- -- ToDo: rm when booting with Haskell 1.3
- -> DoOrListComp
- -> (TcType s -> TcType s) -- Relationship type of pat and rhs in pat <- rhs
- -> (TcStmt s -> Maybe (TcType s) -> thing -> thing)
- -> RenamedStmt
- -> TcM s (thing, LIE s)
- -> TcM s (thing, LIE s)
-
-tcStmt tc_expr do_or_lc m combine stmt@(ReturnStmt exp) do_next
- = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True; Guard -> True } )
- tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
- newTyVarTy mkTypeKind `thenNF_Tc` \ exp_ty ->
- tc_expr exp exp_ty `thenTc` \ (exp', exp_lie) ->
- returnTc (ReturnStmt exp', exp_lie, m exp_ty)
- ) `thenTc` \ (stmt', stmt_lie, stmt_ty) ->
- do_next `thenTc` \ (thing', thing_lie) ->
- returnTc (combine stmt' (Just stmt_ty) thing',
- stmt_lie `plusLIE` thing_lie)
-
-tcStmt tc_expr do_or_lc m combine stmt@(GuardStmt exp src_loc) do_next
- = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True; Guard -> True } )
- newTyVarTy mkTypeKind `thenNF_Tc` \ exp_ty ->
- tcAddSrcLoc src_loc (
- tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
- tc_expr exp boolTy `thenTc` \ (exp', exp_lie) ->
- returnTc (GuardStmt exp' src_loc, exp_lie)
- )) `thenTc` \ (stmt', stmt_lie) ->
- do_next `thenTc` \ (thing', thing_lie) ->
- returnTc (combine stmt' Nothing thing',
- stmt_lie `plusLIE` thing_lie)
-
-tcStmt tc_expr do_or_lc m combine stmt@(ExprStmt exp src_loc) do_next
- = ASSERT( case do_or_lc of { DoStmt -> True; ListComp -> False; Guard -> False } )
- newTyVarTy mkTypeKind `thenNF_Tc` \ exp_ty ->
- tcAddSrcLoc src_loc (
- tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
- newTyVarTy mkTypeKind `thenNF_Tc` \ tau ->
- let
- -- exp has type (m tau) for some tau (doesn't matter what)
- exp_ty = m tau
- in
- tc_expr exp exp_ty `thenTc` \ (exp', exp_lie) ->
- returnTc (ExprStmt exp' src_loc, exp_lie, exp_ty)
- )) `thenTc` \ (stmt', stmt_lie, stmt_ty) ->
- do_next `thenTc` \ (thing', thing_lie) ->
- returnTc (combine stmt' (Just stmt_ty) thing',
- stmt_lie `plusLIE` thing_lie)
-
-tcStmt tc_expr do_or_lc m combine stmt@(BindStmt pat exp src_loc) do_next
- = newMonoIds (collectPatBinders pat) mkBoxedTypeKind $ \ _ ->
- tcAddSrcLoc src_loc (
- tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
- tcPat pat `thenTc` \ (pat', pat_lie, pat_ty) ->
- tc_expr exp (m pat_ty) `thenTc` \ (exp', exp_lie) ->
-
- -- NB: the environment has been extended with the new binders
- -- which the rhs can't "see", but the renamer should have made
- -- sure that everything is distinct by now, so there's no problem.
- -- Putting the tcExpr before the newMonoIds messes up the nesting
- -- of error contexts, so I didn't bother
-
- returnTc (BindStmt pat' exp' src_loc, pat_lie `plusLIE` exp_lie)
- )) `thenTc` \ (stmt', stmt_lie) ->
- do_next `thenTc` \ (thing', thing_lie) ->
- returnTc (combine stmt' Nothing thing',
- stmt_lie `plusLIE` thing_lie)
-
-tcStmt tc_expr do_or_lc m combine (LetStmt binds) do_next
- = tcBindsAndThen -- No error context, but a binding group is
- combine' -- rather a large thing for an error context anyway
- binds
- do_next
- where
- combine' is_rec binds' thing' = combine (LetStmt (MonoBind binds' [] is_rec)) Nothing thing'
-\end{code}
%************************************************************************
%* *
Just (record_ty, field_ty) = splitFunTy_maybe tau
in
unifyTauTy expected_record_ty record_ty `thenTc_`
- tcPolyExpr (ptext SLIT("type of field") <+> quotes (ppr field_label))
- rhs field_ty `thenTc` \ (rhs', lie) ->
+ tcPolyExpr rhs field_ty `thenTc` \ (rhs', lie, _, _, _) ->
returnTc ((RealId sel_id, rhs', pun_flag), lie)
badFields rbinds data_con
%************************************************************************
%* *
-\subsection{@tcExprs@ typechecks a {\em list} of expressions}
+\subsection{@tcMonoExprs@ typechecks a {\em list} of expressions}
%* *
%************************************************************************
\begin{code}
-tcExprs :: [RenamedHsExpr] -> [TcType s] -> TcM s ([TcExpr s], LIE s)
+tcMonoExprs :: [RenamedHsExpr] -> [TcType s] -> TcM s ([TcExpr s], LIE s)
-tcExprs [] [] = returnTc ([], emptyLIE)
-tcExprs (expr:exprs) (ty:tys)
- = tcExpr expr ty `thenTc` \ (expr', lie1) ->
- tcExprs exprs tys `thenTc` \ (exprs', lie2) ->
+tcMonoExprs [] [] = returnTc ([], emptyLIE)
+tcMonoExprs (expr:exprs) (ty:tys)
+ = tcMonoExpr expr ty `thenTc` \ (expr', lie1) ->
+ tcMonoExprs exprs tys `thenTc` \ (exprs', lie2) ->
returnTc (expr':exprs', lie1 `plusLIE` lie2)
\end{code}
quotes (ppr fun) <> text ", namely"])
4 (quotes (ppr arg))
-stmtCtxt do_or_lc stmt
- = hang (ptext SLIT("In a") <+> whatever <> colon)
- 4 (ppr stmt)
- where
- whatever = case do_or_lc of
- ListComp -> ptext SLIT("list-comprehension qualifier")
- DoStmt -> ptext SLIT("do statement")
- Guard -> ptext SLIT("guard")
-
wrongArgsCtxt too_many_or_few fun args
= hang (ptext SLIT("Probable cause:") <+> ppr fun
<+> ptext SLIT("is applied to") <+> text too_many_or_few
\section[TcGRHSs]{Typecheck guarded right-hand-sides}
\begin{code}
-module TcGRHSs ( tcGRHSsAndBinds ) where
+module TcGRHSs ( tcGRHSsAndBinds, tcStmt ) where
#include "HsVersions.h"
-import HsSyn ( HsBinds(..), GRHSsAndBinds(..), GRHS(..), DoOrListComp(..) )
-import RnHsSyn ( RenamedGRHSsAndBinds, RenamedGRHS )
-import TcHsSyn ( TcGRHSsAndBinds, TcGRHS )
+import {-# SOURCE #-} TcExpr( tcExpr )
+
+import HsSyn ( HsBinds(..), GRHSsAndBinds(..), GRHS(..), DoOrListComp(..),
+ Stmt(..),
+ collectPatBinders
+ )
+import RnHsSyn ( RenamedGRHSsAndBinds, RenamedGRHS, RenamedStmt )
+import TcHsSyn ( TcGRHSsAndBinds, TcGRHS, TcStmt )
import TcMonad
import Inst ( Inst, LIE, plusLIE )
import TcBinds ( tcBindsAndThen )
-import TcExpr ( tcExpr, tcStmt )
-import TcType ( TcType )
+import TcPat ( tcPat )
+import TcType ( TcType, newTyVarTy )
+import TcEnv ( newMonoIds )
+import TysWiredIn ( boolTy )
+import Kind ( mkTypeKind, mkBoxedTypeKind )
+import Outputable
\end{code}
+
+%************************************************************************
+%* *
+\subsection{GRHSs}
+%* *
+%************************************************************************
+
\begin{code}
tcGRHSs :: TcType s -> [RenamedGRHS] -> TcM s ([TcGRHS s], LIE s)
where
tcStmts [] = tcExpr expr expected_ty `thenTc` \ (expr2, expr_lie) ->
returnTc (([], expr2), expr_lie)
- tcStmts (stmt:stmts) = tcStmt tcExpr Guard (\x->x) combine stmt $
+ tcStmts (stmt:stmts) = tcStmt Guard (\x->x) combine stmt $
tcStmts stmts
combine stmt _ (stmts, expr) = (stmt:stmts, expr)
\end{code}
+%************************************************************************
+%* *
+\subsection{GRHSsAndBinds}
+%* *
+%************************************************************************
+
@tcGRHSsAndBinds@ typechecks (grhss where binds), returning suitable
pieces.
combiner is_rec binds grhss
= GRHSsAndBindsOut grhss (MonoBind binds [] is_rec) expected_ty
\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Record bindings}
+%* *
+%************************************************************************
+
+
+\begin{code}
+tcStmt :: DoOrListComp
+ -> (TcType s -> TcType s) -- Relationship type of pat and rhs in pat <- rhs
+ -> (TcStmt s -> Maybe (TcType s) -> thing -> thing)
+ -> RenamedStmt
+ -> TcM s (thing, LIE s)
+ -> TcM s (thing, LIE s)
+
+tcStmt do_or_lc m combine stmt@(ReturnStmt exp) do_next
+ = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True; Guard -> True } )
+ tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
+ newTyVarTy mkTypeKind `thenNF_Tc` \ exp_ty ->
+ tcExpr exp exp_ty `thenTc` \ (exp', exp_lie) ->
+ returnTc (ReturnStmt exp', exp_lie, m exp_ty)
+ ) `thenTc` \ (stmt', stmt_lie, stmt_ty) ->
+ do_next `thenTc` \ (thing', thing_lie) ->
+ returnTc (combine stmt' (Just stmt_ty) thing',
+ stmt_lie `plusLIE` thing_lie)
+
+tcStmt do_or_lc m combine stmt@(GuardStmt exp src_loc) do_next
+ = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True; Guard -> True } )
+ newTyVarTy mkTypeKind `thenNF_Tc` \ exp_ty ->
+ tcAddSrcLoc src_loc (
+ tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
+ tcExpr exp boolTy `thenTc` \ (exp', exp_lie) ->
+ returnTc (GuardStmt exp' src_loc, exp_lie)
+ )) `thenTc` \ (stmt', stmt_lie) ->
+ do_next `thenTc` \ (thing', thing_lie) ->
+ returnTc (combine stmt' Nothing thing',
+ stmt_lie `plusLIE` thing_lie)
+
+tcStmt do_or_lc m combine stmt@(ExprStmt exp src_loc) do_next
+ = ASSERT( case do_or_lc of { DoStmt -> True; ListComp -> False; Guard -> False } )
+ newTyVarTy mkTypeKind `thenNF_Tc` \ exp_ty ->
+ tcAddSrcLoc src_loc (
+ tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
+ newTyVarTy mkTypeKind `thenNF_Tc` \ tau ->
+ let
+ -- exp has type (m tau) for some tau (doesn't matter what)
+ exp_ty = m tau
+ in
+ tcExpr exp exp_ty `thenTc` \ (exp', exp_lie) ->
+ returnTc (ExprStmt exp' src_loc, exp_lie, exp_ty)
+ )) `thenTc` \ (stmt', stmt_lie, stmt_ty) ->
+ do_next `thenTc` \ (thing', thing_lie) ->
+ returnTc (combine stmt' (Just stmt_ty) thing',
+ stmt_lie `plusLIE` thing_lie)
+
+tcStmt do_or_lc m combine stmt@(BindStmt pat exp src_loc) do_next
+ = newMonoIds (collectPatBinders pat) mkBoxedTypeKind $ \ _ ->
+ tcAddSrcLoc src_loc (
+ tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
+ tcPat pat `thenTc` \ (pat', pat_lie, pat_ty) ->
+ tcExpr exp (m pat_ty) `thenTc` \ (exp', exp_lie) ->
+
+ -- NB: the environment has been extended with the new binders
+ -- which the rhs can't "see", but the renamer should have made
+ -- sure that everything is distinct by now, so there's no problem.
+ -- Putting the tcExpr before the newMonoIds messes up the nesting
+ -- of error contexts, so I didn't bother
+
+ returnTc (BindStmt pat' exp' src_loc, pat_lie `plusLIE` exp_lie)
+ )) `thenTc` \ (stmt', stmt_lie) ->
+ do_next `thenTc` \ (thing', thing_lie) ->
+ returnTc (combine stmt' Nothing thing',
+ stmt_lie `plusLIE` thing_lie)
+
+tcStmt do_or_lc m combine (LetStmt binds) do_next
+ = tcBindsAndThen -- No error context, but a binding group is
+ combine' -- rather a large thing for an error context anyway
+ binds
+ do_next
+ where
+ combine' is_rec binds' thing' = combine (LetStmt (MonoBind binds' [] is_rec)) Nothing thing'
+
+
+stmtCtxt do_or_lc stmt
+ = hang (ptext SLIT("In a") <+> whatever <> colon)
+ 4 (ppr stmt)
+ where
+ whatever = case do_or_lc of
+ ListComp -> ptext SLIT("list-comprehension qualifier")
+ DoStmt -> ptext SLIT("do statement")
+ Guard -> ptext SLIT("guard")
+\end{code}
produced don't get through the typechecker.
\end{itemize}
+
+deriveEq :: RdrName -- Class
+ -> RdrName -- Type constructor
+ -> [ (RdrName, [RdrType]) ] -- Constructors
+ -> (RdrContext, -- Context for the inst decl
+ [RdrBind], -- Binds in the inst decl
+ [RdrBind]) -- Extra value bindings outside
+
+deriveEq clas tycon constrs
+ = (context, [eq_bind, ne_bind], [])
+ where
+ context = [(clas, [ty]) | (_, tys) <- constrs, ty <- tys]
+
+ ne_bind = mkBind
+ (nullary_cons, non_nullary_cons) = partition is_nullary constrs
+ is_nullary (_, args) = null args
+
\begin{code}
gen_Eq_binds :: TyCon -> RdrNameMonoBinds
import HsSyn ( HsDecl(..), InstDecl(..),
HsBinds(..), MonoBinds(..), GRHSsAndBinds(..), GRHS(..),
- HsExpr(..), InPat(..), HsLit(..),
+ HsExpr(..), InPat(..), HsLit(..), Sig(..),
unguardedRHS,
collectMonoBinders, andMonoBinds
)
+import HsBinds ( sigsForMe )
import RnHsSyn ( RenamedHsBinds, RenamedMonoBinds,
RenamedInstDecl, RenamedHsExpr,
RenamedSig, RenamedHsDecl
)
import TcHsSyn ( TcMonoBinds, TcIdOcc(..), TcIdBndr,
- maybeBoxedPrimType
+ maybeBoxedPrimType, tcIdType
)
import TcBinds ( tcPragmaSigs )
)
import CmdLineOpts ( opt_GlasgowExts, opt_WarnMissingMethods )
import Class ( classBigSig, Class )
-import Id ( isNullaryDataCon, dataConArgTys, Id )
+import Id ( isNullaryDataCon, dataConArgTys, replaceIdInfo, idName, Id )
import Maybes ( maybeToBool, seqMaybe, catMaybes )
import Name ( nameOccName, mkLocalName,
isLocallyDefined, Module,
NamedThing(..)
)
-import PrelVals ( nO_METHOD_BINDING_ERROR_ID )
+import PrelVals ( nO_METHOD_BINDING_ERROR_ID, eRROR_ID )
import PprType ( pprParendType, pprConstraint )
import SrcLoc ( SrcLoc, noSrcLoc )
import TyCon ( isSynTyCon, isDataTyCon, tyConDerivings )
tcInstTheta tenv inst_decl_theta `thenNF_Tc` \ inst_decl_theta' ->
-- Instantiate the super-class context with inst_tys
-
tcInstTheta (zipTyVarEnv class_tyvars inst_tys') sc_theta `thenNF_Tc` \ sc_theta' ->
-- Create dictionary Ids from the specified instance contexts.
newDicts origin inst_decl_theta' `thenNF_Tc` \ (inst_decl_dicts, _) ->
newDicts origin [(clas,inst_tys')] `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
- -- Now process any INLINE or SPECIALIZE pragmas for the methods
- -- ...[NB May 97; all ignored except INLINE]
- tcPragmaSigs uprags `thenTc` \ (prag_fn, spec_binds, spec_lie) ->
-
-- Check that all the method bindings come from this class
let
check_from_this_class (bndr, loc)
tcExtendGlobalValEnv (catMaybes defm_ids) (
-- Default-method Ids may be mentioned in synthesised RHSs
- mapAndUnzip3Tc (tcInstMethodBind clas inst_tys' inst_tyvars' monobinds)
+ mapAndUnzip3Tc (tcInstMethodBind clas inst_tys' inst_tyvars' monobinds uprags)
(op_sel_ids `zip` defm_ids)
) `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) ->
+ -- Deal with SPECIALISE instance pragmas
+ let
+ dfun_prags = [Sig (idName dfun_id) ty loc | SpecInstSig ty loc <- uprags]
+ in
+ tcExtendGlobalValEnv [dfun_id] (
+ tcPragmaSigs dfun_prags
+ ) `thenTc` \ (prag_info_fn, prag_binds, prag_lie) ->
+
-- Check the overloading constraints of the methods and superclasses
mapNF_Tc zonkSigTyVar inst_tyvars' `thenNF_Tc` \ zonked_inst_tyvars ->
inst_tyvars_set
dfun_arg_dicts -- NB! Don't include this_dict here, else the sc_dicts
-- get bound by just selecting from this_dict!!
- (sc_dicts `plusLIE` methods_lie)
+ (sc_dicts `plusLIE` methods_lie `plusLIE` prag_lie)
) `thenTc` \ (const_lie, lie_binds) ->
-- Create the result bindings
let
- dict_constr = classDataCon clas
-
- con_app = foldl HsApp (TyApp (HsVar (RealId dict_constr)) inst_tys')
- (map HsVar (sc_dict_ids ++ meth_ids))
+ dict_constr = classDataCon clas
+ scs_and_meths = sc_dict_ids ++ meth_ids
+
+ dict_rhs
+ | null scs_and_meths
+ = -- Blatant special case for CCallable, CReturnable
+ -- If the dictionary is empty then we should never
+ -- select anything from it, so we make its RHS just
+ -- emit an error message. This in turn means that we don't
+ -- mention the constructor, which doesn't exist for CCallable, CReturnable
+ -- Hardly beautiful, but only three extra lines.
+ HsApp (TyApp (HsVar (RealId eRROR_ID)) [tcIdType this_dict_id])
+ (HsLit (HsString (_PK_ ("Compiler error: bad dictionary " ++ showSDoc (ppr clas)))))
+
+ | otherwise -- The common case
+ = foldl HsApp (TyApp (HsVar (RealId dict_constr)) inst_tys')
+ (map HsVar (sc_dict_ids ++ meth_ids))
-- We don't produce a binding for the dict_constr; instead we
-- rely on the simplifier to unfold this saturated application
- dict_bind = VarMonoBind this_dict_id con_app
+ dict_bind = VarMonoBind this_dict_id dict_rhs
method_binds = andMonoBinds method_binds_s
+ final_dfun_id = replaceIdInfo dfun_id (prag_info_fn (idName dfun_id))
+ -- Pretty truesome
main_bind
= AbsBinds
zonked_inst_tyvars
dfun_arg_dicts_ids
- [(inst_tyvars', RealId dfun_id, this_dict_id)]
+ [(inst_tyvars', RealId final_dfun_id, this_dict_id)]
(lie_binds `AndMonoBinds`
method_binds `AndMonoBinds`
+ prag_binds `AndMonoBinds`
dict_bind)
in
- returnTc (const_lie `plusLIE` spec_lie,
- main_bind `AndMonoBinds` spec_binds)
+ returnTc (const_lie,
+ main_bind `AndMonoBinds` prag_binds)
\end{code}
-> [TcType s] -- Instance types
-> [TcTyVar s] -- and their free (sig) tyvars
-> RenamedMonoBinds -- Method binding
+ -> [RenamedSig] -- Pragmas
-> (Id, Maybe Id) -- Selector id and default-method id
-> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s))
-tcInstMethodBind clas inst_tys inst_tyvars meth_binds (sel_id, maybe_dm_id)
+tcInstMethodBind clas inst_tys inst_tyvars meth_binds prags (sel_id, maybe_dm_id)
= tcGetSrcLoc `thenNF_Tc` \ loc ->
tcGetUnique `thenNF_Tc` \ uniq ->
let
- meth_occ = getOccName sel_id
+ sel_name = idName sel_id
+ meth_occ = getOccName sel_name
default_meth_name = mkLocalName uniq meth_occ loc
maybe_meth_bind = find meth_occ meth_binds
the_meth_bind = case maybe_meth_bind of
Just stuff -> stuff
Nothing -> mk_default_bind default_meth_name loc
+ meth_prags = sigsForMe (== sel_name) prags
in
-- Warn if no method binding, only if -fwarn-missing-methods
(omittedMethodWarn sel_id clas) `thenNF_Tc_`
-- Typecheck the method binding
- tcMethodBind clas origin inst_tys inst_tyvars sel_id the_meth_bind
+ tcMethodBind clas origin inst_tys inst_tyvars sel_id the_meth_bind meth_prags
where
origin = InstanceDeclOrigin -- Poor
(HsLit (HsString (_PK_ (error_msg loc))))
error_msg loc = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
-
\end{code}
projects / ghc-hetmet.git / commitdiff