From: sof Date: Mon, 6 Apr 1998 18:39:39 +0000 (+0000) Subject: [project @ 1998-04-06 18:38:36 by sof] X-Git-Tag: Approx_2487_patches~835 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=83817d01dff687643eee23218435b968ba358a25;p=ghc-hetmet.git [project @ 1998-04-06 18:38:36 by sof] Misc changes by Simon to emit and handle cross-module specialisations --- diff --git a/ghc/compiler/basicTypes/BasicTypes.lhs b/ghc/compiler/basicTypes/BasicTypes.lhs index b10fec9..9ea2e6f 100644 --- a/ghc/compiler/basicTypes/BasicTypes.lhs +++ b/ghc/compiler/basicTypes/BasicTypes.lhs @@ -173,7 +173,17 @@ data TopLevelFlag %************************************************************************ \begin{code} -data RecFlag - = Recursive - | NonRecursive +data RecFlag = Recursive + | NonRecursive +\end{code} + +%************************************************************************ +%* * +\subsection{Strictness indication} +%* * +%************************************************************************ + +\begin{code} +data StrictnessMark = MarkedStrict + | NotMarkedStrict \end{code} diff --git a/ghc/compiler/basicTypes/MkId.hi-boot b/ghc/compiler/basicTypes/MkId.hi-boot index 924c378..4ecec96 100644 --- a/ghc/compiler/basicTypes/MkId.hi-boot +++ b/ghc/compiler/basicTypes/MkId.hi-boot @@ -4,4 +4,3 @@ MkId mkDataCon mkTupleCon ; _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 ;; - diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index 216538e..bb968a3 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -16,6 +16,7 @@ module MkId ( mkImportedId, mkUserId, mkUserLocal, mkSysLocal, + mkSpecPragmaId, mkDataCon, mkTupleCon, @@ -90,6 +91,9 @@ mkSysLocal str uniq ty loc 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 diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index 10d33e3..7352097 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -19,7 +19,7 @@ import CoreSyn 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, @@ -27,7 +27,8 @@ import Id ( idType, isBottomingId, dataConRepType, isDataCon, isNewCon, isAlgCo ) import Maybes ( catMaybes ) import Name ( isLocallyDefined, getSrcLoc, Name{-instance NamedThing-}, - NamedThing(..) ) + NamedThing(..) + ) import PprCore import ErrUtils ( doIfSet, ghcExit ) import PrimOp ( primOpType ) diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index b557803..d6246f1 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -222,10 +222,21 @@ data Sig name | 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} @@ -252,7 +263,7 @@ ppr_sig (SpecSig var ty using _) 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} diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 4503e05..f7889a4 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -284,7 +284,7 @@ instance (NamedThing name, Outputable name, Outputable pat) %************************************************************************ %* * -\subsection[InstDecl]{An instance declaration (also, @SpecInstSig@)} +\subsection[InstDecl]{An instance declaration %* * %************************************************************************ @@ -317,21 +317,6 @@ instance (NamedThing name, Outputable name, Outputable pat) 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} %************************************************************************ %* * diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs index 237b660..a6219b1 100644 --- a/ghc/compiler/hsSyn/HsSyn.lhs +++ b/ghc/compiler/hsSyn/HsSyn.lhs @@ -35,7 +35,7 @@ import HsDecls ( HsDecl(..), TyDecl(..), InstDecl(..), ClassDecl(..), DefaultDecl(..), FixityDecl(..), ConDecl(..), ConDetails(..), BangType(..), - IfaceSig(..), HsIdInfo, SpecDataSig(..), SpecInstSig(..), + IfaceSig(..), HsIdInfo, SpecDataSig(..), hsDeclName ) import HsExpr diff --git a/ghc/compiler/reader/PrefixSyn.lhs b/ghc/compiler/reader/PrefixSyn.lhs index 4091903..9d1d8d0 100644 --- a/ghc/compiler/reader/PrefixSyn.lhs +++ b/ghc/compiler/reader/PrefixSyn.lhs @@ -50,18 +50,9 @@ data RdrBinding -- 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} diff --git a/ghc/compiler/reader/PrefixToHs.lhs b/ghc/compiler/reader/PrefixToHs.lhs index acc8627..b91f75b 100644 --- a/ghc/compiler/reader/PrefixToHs.lhs +++ b/ghc/compiler/reader/PrefixToHs.lhs @@ -37,20 +37,19 @@ import Util ( mapAndUnzip, panic, assertPanic ) 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.} @@ -89,12 +88,8 @@ cvMonoBindsAndSigs sf sig_cvtr fb 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]) diff --git a/ghc/compiler/reader/RdrHsSyn.lhs b/ghc/compiler/reader/RdrHsSyn.lhs index f7f9eed..346ca51 100644 --- a/ghc/compiler/reader/RdrHsSyn.lhs +++ b/ghc/compiler/reader/RdrHsSyn.lhs @@ -31,7 +31,6 @@ module RdrHsSyn ( RdrNamePat, RdrNameHsType, RdrNameSig, - RdrNameSpecInstSig, RdrNameStmt, RdrNameTyDecl, @@ -91,7 +90,6 @@ type RdrNameMonoBinds = MonoBinds Unused RdrName RdrNamePat 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 diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs index d2b2f07..ce285de 100644 --- a/ghc/compiler/reader/ReadPrefix.lhs +++ b/ghc/compiler/reader/ReadPrefix.lhs @@ -620,15 +620,15 @@ wlk_sig_thing (U_sbind sbindids sbindid srcline) = 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 @@ -639,29 +639,15 @@ wlk_sig_thing (U_vspec_uprag uvar vspec_tys srcline) -- 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} %************************************************************************ diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index cd04844..29945ae 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -11,7 +11,7 @@ they may be affected by renaming (which isn't fully worked out yet). \begin{code} module RnBinds ( rnTopBinds, rnTopMonoBinds, - rnMethodBinds, + rnMethodBinds, renameSigs, rnBinds, rnMonoBinds ) where @@ -20,6 +20,7 @@ module RnBinds ( import {-# SOURCE #-} RnSource ( rnHsSigType ) import HsSyn +import HsBinds ( sigsForMe ) import RdrHsSyn import RnHsSyn import RnMonad @@ -262,7 +263,7 @@ rn_mono_binds top_lev binders mbinds sigs -- 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 @@ -299,7 +300,7 @@ flattenMonoBinds sigs (PatMonoBind pat grhss_and_binds locn) -- 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 @@ -316,7 +317,7 @@ flattenMonoBinds sigs (FunMonoBind name inf matches locn) 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 @@ -437,17 +438,19 @@ mkEdges flat_info %* * %************************************************************************ -@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' -> @@ -455,8 +458,9 @@ rnBindSigs top_lev binders 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 @@ -464,6 +468,11 @@ rnBindSigs top_lev binders sigs 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: @@ -476,6 +485,11 @@ renameSig (Sig v ty src_loc) 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 -> @@ -491,21 +505,16 @@ renameSig (InlineSig v src_loc) = 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) @@ -517,14 +526,8 @@ cmp_sig other_1 other_2 -- Tags *must* be different 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} %************************************************************************ @@ -536,24 +539,25 @@ sig_name (MagicUnfoldingSig n _ _) = n \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)] diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 3dd375f..1d52c5f 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -44,7 +44,6 @@ type RenamedPat = InPat Name 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 diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index d4d73fb..ef1b761 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -18,7 +18,7 @@ import RnHsSyn 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, @@ -26,9 +26,10 @@ import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn, lookupImplicitOccRn, bi 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 ) @@ -173,7 +174,7 @@ rnDecl (ClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname src_ 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) @@ -239,7 +240,10 @@ rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun src_loc)) -- 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 @@ -278,27 +282,6 @@ rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun src_loc)) 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} %********************************************************* diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index 4f55e08..05c5782 100644 --- a/ghc/compiler/simplCore/OccurAnal.lhs +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -22,7 +22,7 @@ import CmdLineOpts ( opt_D_dump_occur_anal, SimplifierSwitch(..) ) import CoreSyn import Digraph ( stronglyConnCompR, SCC(..) ) import Id ( idWantsToBeINLINEd, addNoInlinePragma, nukeNoInlinePragma, - omitIfaceSigForId, + omitIfaceSigForId, isSpecPragmaId, idType, idUnique, Id, emptyIdSet, unionIdSets, mkIdSet, elementOfIdSet, @@ -790,7 +790,7 @@ tagBinder usage binder = usage_of usage binder - | isExported binder + | isExported binder || isSpecPragmaId binder = noBinderInfo -- Visible-elsewhere things count as many | otherwise = case (lookupIdEnv usage binder) of diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index a3ad502..c7d2ff4 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -14,7 +14,7 @@ module Specialise ( import MkId ( mkUserLocal ) import Id ( Id, DictVar, idType, - getIdSpecialisation, setIdSpecialisation, + getIdSpecialisation, setIdSpecialisation, isSpecPragmaId, IdSet, mkIdSet, addOneToIdSet, intersectIdSets, isEmptyIdSet, emptyIdSet, unionIdSets, minusIdSet, unitIdSet, elementOfIdSet, @@ -58,10 +58,9 @@ infixr 9 `thenSM` %************************************************************************ 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. @@ -125,12 +124,12 @@ and create a local instance of f, defined thus: f@t1/t2 = 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. @@ -157,8 +156,8 @@ becomes 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. @@ -240,22 +239,23 @@ polymorphic versions. Thus: f@t1/ = /\b -> 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 @@ -284,11 +284,6 @@ at the defn of g. Instead, we have to float out the (new) defn of deq 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 @@ -360,13 +355,6 @@ ordinary function definitions: 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? ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -377,6 +365,9 @@ for ordinary functions; and when we specialised their bodies, we might get 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. @@ -385,33 +376,6 @@ survive solely by spitting out *usage* information, and then reading that 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 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -423,6 +387,8 @@ and data types. Then we equivalence-class it and spit it out. 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 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -485,25 +451,27 @@ response to a SPECIALIZE pragma on the Eq [a] instance decl. 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? ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -528,98 +496,6 @@ Still, this is no great hardship, because we intend to eliminate 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 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -832,6 +708,10 @@ specBind (NonRec bndr rhs) body_uds 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 @@ -949,8 +829,13 @@ specDefn calls (fn, rhs) -- 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) @@ -1256,3 +1141,71 @@ newIdSM old_id new_ty \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. + diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 6d87eb9..7bb409e 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -11,9 +11,10 @@ module TcBinds ( tcBindsAndThen, tcTopBindsAndThen, #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 @@ -28,7 +29,8 @@ import Inst ( Inst, LIE, emptyLIE, plusLIE, plusLIEs, InstOrigin(..), newDicts, tyVarsOfInst, instToId, newMethodWithGivenTy, zonkInst, pprInsts ) -import TcEnv ( tcExtendLocalValEnv, tcLookupLocalValueOK, newLocalId, +import TcEnv ( tcExtendLocalValEnv, tcLookupLocalValueOK, + newLocalId, newSpecPragmaId, tcGetGlobalTyVars, tcExtendGlobalTyVars ) import TcMatches ( tcMatchesFun ) @@ -155,7 +157,7 @@ tcBinds top_lvl (MonoBind bind sigs is_rec) -- 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) -> @@ -336,13 +338,14 @@ tcBindWithSigs top_lvl binder_names mbind tc_ty_sigs is_rec prag_info_fn 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 @@ -621,18 +624,17 @@ maybeSig (sig@(TySigInfo sig_name _ _ _ _ _) : sigs) name \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 @@ -796,16 +798,12 @@ tcPragmaSigs :: [RenamedSig] -- The pragma signatures 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. @@ -857,51 +855,61 @@ and the simplifer won't discard SpecIds for exporte things anyway, so maybe this 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} diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index f9f28b3..6cc6a7a 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -15,15 +15,16 @@ import HsPragmas ( ClassPragmas(..) ) 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 ) @@ -410,7 +411,7 @@ tcDefaultMethodBinds clas default_binds | 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 @@ -475,9 +476,10 @@ tcMethodBind -- 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') -> @@ -485,10 +487,14 @@ tcMethodBind clas origin inst_tys inst_tyvars sel_id meth_bind (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 @@ -499,7 +505,9 @@ tcMethodBind clas origin inst_tys inst_tyvars sel_id meth_bind 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) diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 5ba7bf4..6106df1 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -18,13 +18,13 @@ module TcEnv( 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, @@ -38,7 +38,7 @@ import Class ( Class ) import TcMonad import IdInfo ( noIdInfo ) -import Name ( Name, OccName(..), +import Name ( Name, OccName(..), nameOccName, maybeWiredInTyConName, maybeWiredInIdName, isLocallyDefined, NamedThing(..) ) @@ -407,6 +407,12 @@ newLocalIds names tys 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} diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 4675575..501eed8 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -4,7 +4,7 @@ \section[TcExpr]{Typecheck an expression} \begin{code} -module TcExpr ( tcExpr, tcStmt, tcId ) where +module TcExpr ( tcExpr, tcId ) where #include "HsVersions.h" @@ -34,10 +34,11 @@ import TcEnv ( TcIdOcc(..), tcInstId, 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 ) @@ -56,7 +57,7 @@ import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys, mkTyConApp, splitForAllTys, splitRhoTy, splitSigmaTy, isTauTy, tyVarsOfType, tyVarsOfTypes, - splitForAllTy_maybe, splitAlgTyConApp, splitAlgTyConApp_maybe + isForAllTy, splitAlgTyConApp, splitAlgTyConApp_maybe ) import TyVar ( emptyTyVarEnv, zipTyVarEnv, elementOfTyVarSet, mkTyVarSet, tyVarSetToList @@ -79,10 +80,88 @@ import ListSetOps ( minusList ) 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} %************************************************************************ @@ -92,7 +171,11 @@ tcExpr :: RenamedHsExpr -- Expession to type check %************************************************************************ \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_` @@ -114,20 +197,20 @@ tcExpr (HsVar name) res_ty 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, _) -> @@ -137,23 +220,23 @@ tcExpr (HsLit lit@(HsLitLit s)) res_ty 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} @@ -161,11 +244,11 @@ tcExpr (HsLit lit@(HsDoublePrim d)) res_ty 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} @@ -177,24 +260,24 @@ tcExpr (HsLit lit@(HsString str)) res_ty %************************************************************************ \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 @@ -202,7 +285,7 @@ tcExpr (HsApp e1 e2) res_ty = accum e1 [e2] 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} @@ -218,7 +301,7 @@ a type error will occur if they aren't. -- 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 @@ -235,11 +318,11 @@ tcExpr in_expr@(SectionL arg op) res_ty -- 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} @@ -252,7 +335,7 @@ arg/result types); unify them with the args/result; and store them for 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 -> @@ -269,7 +352,7 @@ tcExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty -- 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 @@ -283,7 +366,7 @@ tcExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty -- 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]) @@ -294,22 +377,22 @@ tcExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty) res_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) $ @@ -323,44 +406,44 @@ tcExpr in_expr@(HsCase scrut matches src_loc) res_ty 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 @@ -410,7 +493,7 @@ tcExpr (RecordCon con_name _ rbinds) res_ty -- -- 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 @@ -475,7 +558,7 @@ tcExpr (RecordUpd record_expr rbinds) res_ty 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 @@ -497,9 +580,9 @@ tcExpr (RecordUpd record_expr rbinds) res_ty 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) @@ -508,11 +591,11 @@ tcExpr (ArithSeqIn seq@(From expr)) res_ty 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) -> @@ -521,11 +604,11 @@ tcExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2)) res_ty (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) -> @@ -534,12 +617,12 @@ tcExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2)) res_ty (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) -> @@ -556,47 +639,32 @@ tcExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty %************************************************************************ \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. @@ -611,7 +679,7 @@ tcExpr_id id_expr 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} @@ -692,74 +760,10 @@ tcArg :: RenamedHsExpr -- The function (for error messages) 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} @@ -825,7 +829,7 @@ tcDoStmts do_or_lc stmts src_loc res_ty 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) @@ -867,85 +871,6 @@ tcDoStmts do_or_lc stmts src_loc res_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} %************************************************************************ %* * @@ -1002,8 +927,7 @@ tcRecordBinds expected_record_ty rbinds 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 @@ -1016,17 +940,17 @@ 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} @@ -1074,15 +998,6 @@ funAppCtxt fun arg arg_no 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 diff --git a/ghc/compiler/typecheck/TcGRHSs.lhs b/ghc/compiler/typecheck/TcGRHSs.lhs index d19715c..9dd435a 100644 --- a/ghc/compiler/typecheck/TcGRHSs.lhs +++ b/ghc/compiler/typecheck/TcGRHSs.lhs @@ -4,21 +4,37 @@ \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) @@ -38,13 +54,19 @@ tcGRHS expected_ty (GRHS guard expr locn) 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. @@ -66,3 +88,97 @@ tcGRHSsAndBinds expected_ty (GRHSsAndBindsIn grhss binds) 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} diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index 214564c..94e3871 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -138,6 +138,23 @@ instance ... Eq (Foo ...) where 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 diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 85d6071..1c1b1f0 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -13,16 +13,17 @@ module TcInstDcls ( 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 ) @@ -46,13 +47,13 @@ import Bag ( emptyBag, unitBag, unionBags, unionManyBags, ) 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 ) @@ -329,7 +330,6 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_tys 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. @@ -338,10 +338,6 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_tys 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) @@ -356,10 +352,18 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_tys 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 -> @@ -409,33 +413,49 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_tys 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} @@ -451,19 +471,22 @@ tcInstMethodBind -> [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 @@ -474,7 +497,7 @@ tcInstMethodBind clas inst_tys inst_tyvars meth_binds (sel_id, maybe_dm_id) (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 @@ -503,7 +526,6 @@ tcInstMethodBind clas inst_tys inst_tyvars meth_binds (sel_id, maybe_dm_id) (HsLit (HsString (_PK_ (error_msg loc)))) error_msg loc = showSDoc (hcat [ppr loc, text "|", ppr sel_id ]) - \end{code}