diff options
Diffstat (limited to 'compiler/GHC/Hs/Binds.hs')
| -rw-r--r-- | compiler/GHC/Hs/Binds.hs | 140 |
1 files changed, 113 insertions, 27 deletions
diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs index 987631dc82..d67d1c4312 100644 --- a/compiler/GHC/Hs/Binds.hs +++ b/compiler/GHC/Hs/Binds.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} @@ -42,17 +43,17 @@ import GHC.Types.Name.Set import GHC.Types.Basic import GHC.Types.SourceText import GHC.Types.SrcLoc as SrcLoc +import GHC.Types.Var import GHC.Data.Bag import GHC.Data.BooleanFormula (LBooleanFormula) import GHC.Types.Name.Reader import GHC.Types.Name -import GHC.Types.Id import GHC.Utils.Outputable import GHC.Utils.Panic -import Data.List (sortBy) import Data.Function +import Data.List (sortBy) import Data.Data (Data) {- @@ -83,7 +84,7 @@ data NHsValBindsLR idL [LSig GhcRn] type instance XValBinds (GhcPass pL) (GhcPass pR) = AnnSortKey -type instance XXValBindsLR (GhcPass pL) (GhcPass pR) +type instance XXValBindsLR (GhcPass pL) pR = NHsValBindsLR (GhcPass pL) -- --------------------------------------------------------------------- @@ -114,12 +115,11 @@ type instance XPatBind GhcRn (GhcPass pR) = NameSet -- ^ See Note [Bind free type instance XPatBind GhcTc (GhcPass pR) = Type -- Type of the GRHSs type instance XVarBind (GhcPass pL) (GhcPass pR) = NoExtField -type instance XAbsBinds (GhcPass pL) (GhcPass pR) = NoExtField type instance XPatSynBind (GhcPass pL) (GhcPass pR) = NoExtField -type instance XXHsBindsLR (GhcPass pL) (GhcPass pR) = DataConCantHappen -type instance XABE (GhcPass p) = NoExtField -type instance XXABExport (GhcPass p) = DataConCantHappen +type instance XXHsBindsLR GhcPs pR = DataConCantHappen +type instance XXHsBindsLR GhcRn pR = DataConCantHappen +type instance XXHsBindsLR GhcTc pR = AbsBinds type instance XPSB (GhcPass idL) GhcPs = EpAnn [AddEpAnn] type instance XPSB (GhcPass idL) GhcRn = NameSet -- ^ Post renaming, FVs. See Note [Bind free vars] @@ -127,6 +127,52 @@ type instance XPSB (GhcPass idL) GhcTc = NameSet type instance XXPatSynBind (GhcPass idL) (GhcPass idR) = DataConCantHappen +-- --------------------------------------------------------------------- + +-- | Typechecked, generalised bindings, used in the output to the type checker. +-- See Note [AbsBinds]. +data AbsBinds = AbsBinds { + abs_tvs :: [TyVar], + abs_ev_vars :: [EvVar], -- ^ Includes equality constraints + + -- | AbsBinds only gets used when idL = idR after renaming, + -- but these need to be idL's for the collect... code in HsUtil + -- to have the right type + abs_exports :: [ABExport], + + -- | Evidence bindings + -- Why a list? See "GHC.Tc.TyCl.Instance" + -- Note [Typechecking plan for instance declarations] + abs_ev_binds :: [TcEvBinds], + + -- | Typechecked user bindings + abs_binds :: LHsBinds GhcTc, + + abs_sig :: Bool -- See Note [The abs_sig field of AbsBinds] + } + + + -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds] + -- + -- Creates bindings for (polymorphic, overloaded) poly_f + -- in terms of monomorphic, non-overloaded mono_f + -- + -- Invariants: + -- 1. 'binds' binds mono_f + -- 2. ftvs is a subset of tvs + -- 3. ftvs includes all tyvars free in ds + -- + -- See Note [AbsBinds] + +-- | Abstraction Bindings Export +data ABExport + = ABE { abe_poly :: Id -- ^ Any INLINE pragma is attached to this Id + , abe_mono :: Id + , abe_wrap :: HsWrapper -- ^ See Note [ABExport wrapper] + -- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly + , abe_prags :: TcSpecPrags -- ^ SPECIALISE pragmas + } + {- Note [AbsBinds] ~~~~~~~~~~~~~~~ @@ -474,29 +520,36 @@ ppr_monobind (FunBind { fun_id = fun, $$ whenPprDebug (pprIfTc @idR $ ppr wrap) ppr_monobind (PatSynBind _ psb) = ppr psb -ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars - , abs_exports = exports, abs_binds = val_binds - , abs_ev_binds = ev_binds }) - = sdocOption sdocPrintTypecheckerElaboration $ \case - False -> pprLHsBinds val_binds - True -> -- Show extra information (bug number: #10662) - hang (text "AbsBinds" - <+> sep [ brackets (interpp'SP tyvars) - , brackets (interpp'SP dictvars) ]) - 2 $ braces $ vcat - [ text "Exports:" <+> - brackets (sep (punctuate comma (map ppr exports))) - , text "Exported types:" <+> - vcat [pprBndr LetBind (abe_poly ex) | ex <- exports] - , text "Binds:" <+> pprLHsBinds val_binds - , pprIfTc @idR (text "Evidence:" <+> ppr ev_binds) - ] - -instance OutputableBndrId p => Outputable (ABExport (GhcPass p)) where +ppr_monobind (XHsBindsLR b) = case ghcPass @idL of +#if __GLASGOW_HASKELL__ <= 900 + GhcPs -> dataConCantHappen b + GhcRn -> dataConCantHappen b +#endif + GhcTc -> ppr_absbinds b + where + ppr_absbinds (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars + , abs_exports = exports, abs_binds = val_binds + , abs_ev_binds = ev_binds }) + = sdocOption sdocPrintTypecheckerElaboration $ \case + False -> pprLHsBinds val_binds + True -> -- Show extra information (bug number: #10662) + hang (text "AbsBinds" + <+> sep [ brackets (interpp'SP tyvars) + , brackets (interpp'SP dictvars) ]) + 2 $ braces $ vcat + [ text "Exports:" <+> + brackets (sep (punctuate comma (map ppr exports))) + , text "Exported types:" <+> + vcat [pprBndr LetBind (abe_poly ex) | ex <- exports] + , text "Binds:" <+> pprLHsBinds val_binds + , pprIfTc @idR (text "Evidence:" <+> ppr ev_binds) + ] + +instance Outputable ABExport where ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags }) = vcat [ sep [ ppr gbl, nest 2 (text "<=" <+> ppr lcl) ] , nest 2 (pprTcSpecPrags prags) - , pprIfTc @p $ nest 2 (text "wrap:" <+> ppr wrap) ] + , ppr $ nest 2 (text "wrap:" <+> ppr wrap) ] instance (OutputableBndrId l, OutputableBndrId r) => Outputable (PatSynBind (GhcPass l) (GhcPass r)) where @@ -618,6 +671,39 @@ data AnnSig } deriving Data +-- | Type checker Specialisation Pragmas +-- +-- 'TcSpecPrags' conveys @SPECIALISE@ pragmas from the type checker to the desugarer +data TcSpecPrags + = IsDefaultMethod -- ^ Super-specialised: a default method should + -- be macro-expanded at every call site + | SpecPrags [LTcSpecPrag] + deriving Data + +-- | Located Type checker Specification Pragmas +type LTcSpecPrag = Located TcSpecPrag + +-- | Type checker Specification Pragma +data TcSpecPrag + = SpecPrag + Id + HsWrapper + InlinePragma + -- ^ The Id to be specialised, a wrapper that specialises the + -- polymorphic function, and inlining spec for the specialised function + deriving Data + +noSpecPrags :: TcSpecPrags +noSpecPrags = SpecPrags [] + +hasSpecPrags :: TcSpecPrags -> Bool +hasSpecPrags (SpecPrags ps) = not (null ps) +hasSpecPrags IsDefaultMethod = False + +isDefaultMethod :: TcSpecPrags -> Bool +isDefaultMethod IsDefaultMethod = True +isDefaultMethod (SpecPrags {}) = False + instance OutputableBndrId p => Outputable (Sig (GhcPass p)) where ppr sig = ppr_sig sig |