diff options
24 files changed, 325 insertions, 533 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 diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index 704dc70b02..595adafdf9 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -1629,6 +1629,9 @@ instance Data DelayedSplice where toConstr a = mkConstr (dataTypeOf a) "DelayedSplice" [] Data.Prefix dataTypeOf a = mkDataType "HsExpr.DelayedSplice" [toConstr a] +-- See Note [Pending Splices] +type SplicePointName = Name + -- | Pending Renamer Splice data PendingRnSplice = PendingRnSplice UntypedSpliceFlavour SplicePointName (LHsExpr GhcRn) diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs index 21cd9b5d76..ff5131f6e0 100644 --- a/compiler/GHC/Hs/Instances.hs +++ b/compiler/GHC/Hs/Instances.hs @@ -63,10 +63,9 @@ deriving instance Data (HsBindLR GhcPs GhcRn) deriving instance Data (HsBindLR GhcRn GhcRn) deriving instance Data (HsBindLR GhcTc GhcTc) --- deriving instance (DataId p) => Data (ABExport p) -deriving instance Data (ABExport GhcPs) -deriving instance Data (ABExport GhcRn) -deriving instance Data (ABExport GhcTc) +deriving instance Data AbsBinds + +deriving instance Data ABExport -- deriving instance DataId p => Data (RecordPatSynField p) deriving instance Data (RecordPatSynField GhcPs) diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs index 43f161f9bd..c81018da40 100644 --- a/compiler/GHC/Hs/Pat.hs +++ b/compiler/GHC/Hs/Pat.hs @@ -452,7 +452,7 @@ isBangedPat (ParPat _ _ p _) = isBangedLPat p isBangedPat (BangPat {}) = True isBangedPat _ = False -looksLazyPatBind :: HsBind (GhcPass p) -> Bool +looksLazyPatBind :: HsBind GhcTc -> Bool -- Returns True of anything *except* -- a StrictHsBind (as above) or -- a VarPat @@ -460,7 +460,7 @@ looksLazyPatBind :: HsBind (GhcPass p) -> Bool -- Looks through AbsBinds looksLazyPatBind (PatBind { pat_lhs = p }) = looksLazyLPat p -looksLazyPatBind (AbsBinds { abs_binds = binds }) +looksLazyPatBind (XHsBindsLR (AbsBinds { abs_binds = binds })) = anyBag (looksLazyPatBind . unLoc) binds looksLazyPatBind _ = False diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index d53fc51786..050fa53d30 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -20,17 +20,19 @@ just attach noSrcSpan to everything. -} - -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -151,7 +153,6 @@ import GHC.Utils.Panic import Data.Either import Data.Function import Data.List ( partition, deleteBy ) -import Data.Proxy {- ************************************************************************ @@ -978,7 +979,7 @@ BUT we have a special case when abs_sig is true; -- information, see Note [Strict binds checks] is GHC.HsToCore.Binds. isUnliftedHsBind :: HsBind GhcTc -> Bool -- works only over typechecked binds isUnliftedHsBind bind - | AbsBinds { abs_exports = exports, abs_sig = has_sig } <- bind + | XHsBindsLR (AbsBinds { abs_exports = exports, abs_sig = has_sig }) <- bind = if has_sig then any (is_unlifted_id . abe_poly) exports else any (is_unlifted_id . abe_mono) exports @@ -993,7 +994,7 @@ isUnliftedHsBind bind -- | Is a binding a strict variable or pattern bind (e.g. @!x = ...@)? isBangedHsBind :: HsBind GhcTc -> Bool -isBangedHsBind (AbsBinds { abs_binds = binds }) +isBangedHsBind (XHsBindsLR (AbsBinds { abs_binds = binds })) = anyBag (isBangedHsBind . unLoc) binds isBangedHsBind (FunBind {fun_matches = matches}) | [L _ match] <- unLoc $ mg_alts matches @@ -1023,7 +1024,7 @@ collectHsIdBinders flag = collect_hs_val_binders True flag collectHsValBinders :: CollectPass (GhcPass idL) => CollectFlag (GhcPass idL) - -> HsValBindsLR (GhcPass idL) (GhcPass idR) + -> HsValBindsLR (GhcPass idL) idR -> [IdP (GhcPass idL)] collectHsValBinders flag = collect_hs_val_binders False flag @@ -1050,7 +1051,7 @@ collectHsBindListBinders flag = foldr (collect_bind False flag . unXRec @p) [] collect_hs_val_binders :: CollectPass (GhcPass idL) => Bool -> CollectFlag (GhcPass idL) - -> HsValBindsLR (GhcPass idL) (GhcPass idR) + -> HsValBindsLR (GhcPass idL) idR -> [IdP (GhcPass idL)] collect_hs_val_binders ps flag = \case ValBinds _ binds _ -> collect_binds ps flag binds [] @@ -1078,18 +1079,15 @@ collect_bind :: forall p idR. CollectPass p -> HsBindLR p idR -> [IdP p] -> [IdP p] -collect_bind _ flag (PatBind { pat_lhs = p }) acc = collect_lpat flag p acc -collect_bind _ _ (FunBind { fun_id = f }) acc = unXRec @p f : acc -collect_bind _ _ (VarBind { var_id = f }) acc = f : acc -collect_bind _ _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc - -- I don't think we want the binders from the abe_binds - - -- binding (hence see AbsBinds) is in zonking in GHC.Tc.Utils.Zonk +collect_bind _ _ (FunBind { fun_id = f }) acc = unXRec @p f : acc +collect_bind _ flag (PatBind { pat_lhs = p }) acc = collect_lpat flag p acc +collect_bind _ _ (VarBind { var_id = f }) acc = f : acc collect_bind omitPatSyn _ (PatSynBind _ (PSB { psb_id = ps })) acc | omitPatSyn = acc | otherwise = unXRec @p ps : acc collect_bind _ _ (PatSynBind _ (XPatSynBind _)) acc = acc -collect_bind _ _ (XHsBindsLR _) acc = acc +collect_bind _ _ (XHsBindsLR b) acc = collectXXHsBindsLR @p @idR b acc + collectMethodBinders :: forall idL idR. UnXRec idL => LHsBindsLR idL idR -> [LIdP idL] -- ^ Used exclusively for the bindings of an instance decl which are all @@ -1110,14 +1108,14 @@ collectLStmtsBinders collectLStmtsBinders flag = concatMap (collectLStmtBinders flag) collectStmtsBinders - :: (CollectPass (GhcPass idL)) + :: CollectPass (GhcPass idL) => CollectFlag (GhcPass idL) -> [StmtLR (GhcPass idL) (GhcPass idR) body] -> [IdP (GhcPass idL)] collectStmtsBinders flag = concatMap (collectStmtBinders flag) collectLStmtBinders - :: (CollectPass (GhcPass idL)) + :: CollectPass (GhcPass idL) => CollectFlag (GhcPass idL) -> LStmtLR (GhcPass idL) (GhcPass idR) body -> [IdP (GhcPass idL)] @@ -1176,7 +1174,7 @@ data CollectFlag p where -- | Collect evidence binders CollWithDictBinders :: CollectFlag GhcTc -collect_lpat :: forall p. (CollectPass p) +collect_lpat :: forall p. CollectPass p => CollectFlag p -> LPat p -> [IdP p] @@ -1203,7 +1201,7 @@ collect_pat flag pat bndrs = case pat of NPat {} -> bndrs NPlusKPat _ n _ _ _ _ -> unXRec @p n : bndrs SigPat _ pat _ -> collect_lpat flag pat bndrs - XPat ext -> collectXXPat (Proxy @p) flag ext bndrs + XPat ext -> collectXXPat @p flag ext bndrs SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)) -> collect_pat flag pat bndrs SplicePat _ _ -> bndrs @@ -1230,10 +1228,11 @@ add_ev_bndr (EvBind { eb_lhs = b }) bs | isId b = b:bs -- In particular, Haddock already makes use of this, with an instance for its 'DocNameI' pass so that -- it can reuse the code in GHC for collecting binders. class UnXRec p => CollectPass p where - collectXXPat :: Proxy p -> CollectFlag p -> XXPat p -> [IdP p] -> [IdP p] + collectXXPat :: CollectFlag p -> XXPat p -> [IdP p] -> [IdP p] + collectXXHsBindsLR :: forall pR. XXHsBindsLR p pR -> [IdP p] -> [IdP p] instance IsPass p => CollectPass (GhcPass p) where - collectXXPat _ flag ext = + collectXXPat flag ext = case ghcPass @p of GhcPs -> dataConCantHappen ext GhcRn @@ -1242,6 +1241,16 @@ instance IsPass p => CollectPass (GhcPass p) where GhcTc -> case ext of CoPat _ pat _ -> collect_pat flag pat ExpansionPat _ pat -> collect_pat flag pat + collectXXHsBindsLR ext = + case ghcPass @p of + GhcPs -> dataConCantHappen ext + GhcRn -> dataConCantHappen ext + GhcTc -> case ext of + AbsBinds { abs_exports = dbinds } -> (map abe_poly dbinds ++) + -- I don't think we want the binders from the abe_binds + + -- binding (hence see AbsBinds) is in zonking in GHC.Tc.Utils.Zonk + {- Note [Dictionary binders in ConPatOut] diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs index a8935e9cd9..9220326258 100644 --- a/compiler/GHC/HsToCore/Binds.hs +++ b/compiler/GHC/HsToCore/Binds.hs @@ -201,10 +201,12 @@ dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss else [] ; return (force_var', sel_binds) } -dsHsBind dflags (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts - , abs_exports = exports - , abs_ev_binds = ev_binds - , abs_binds = binds, abs_sig = has_sig }) +dsHsBind + dflags + (XHsBindsLR (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts + , abs_exports = exports + , abs_ev_binds = ev_binds + , abs_binds = binds, abs_sig = has_sig })) = do { ds_binds <- addTyCs FromSource (listToBag dicts) $ dsLHsBinds binds -- addTyCs: push type constraints deeper @@ -220,7 +222,7 @@ dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind" ----------------------- dsAbsBinds :: DynFlags - -> [TyVar] -> [EvVar] -> [ABExport GhcTc] + -> [TyVar] -> [EvVar] -> [ABExport] -> [CoreBind] -- Desugared evidence bindings -> ([Id], [(Id,CoreExpr)]) -- Desugared value bindings -> Bool -- Single binding with signature @@ -271,7 +273,7 @@ dsAbsBinds dflags tyvars dicts exports -- lcl_id{inl-prag} = rhs -- Auxiliary binds -- gbl_id = lcl_id |> co -- Main binds | null tyvars, null dicts - = do { let mk_main :: ABExport GhcTc -> DsM (Id, CoreExpr) + = do { let mk_main :: ABExport -> DsM (Id, CoreExpr) mk_main (ABE { abe_poly = gbl_id, abe_mono = lcl_id , abe_wrap = wrap }) -- No SpecPrags (no dicts) @@ -360,7 +362,7 @@ dsAbsBinds dflags tyvars dicts exports [] lcls -- find exports or make up new exports for force variables - get_exports :: [Id] -> DsM ([Id], [ABExport GhcTc]) + get_exports :: [Id] -> DsM ([Id], [ABExport]) get_exports lcls = foldM (\(glbls, exports) lcl -> case lookupVarEnv global_env lcl of @@ -373,8 +375,7 @@ dsAbsBinds dflags tyvars dicts exports mk_export local = do global <- newSysLocalDs Many (exprType (mkLams tyvars (mkLams dicts (Var local)))) - return (ABE { abe_ext = noExtField - , abe_poly = global + return (ABE { abe_poly = global , abe_mono = local , abe_wrap = WpHole , abe_prags = SpecPrags [] }) diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs index c59beb402c..93694c4750 100644 --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -285,12 +285,13 @@ addTickLHsBinds :: LHsBinds GhcTc -> TM (LHsBinds GhcTc) addTickLHsBinds = mapBagM addTickLHsBind addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc) -addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds, - abs_exports = abs_exports })) = +addTickLHsBind (L pos (XHsBindsLR bind@(AbsBinds { abs_binds = binds + , abs_exports = abs_exports + }))) = withEnv add_exports $ withEnv add_inlines $ do binds' <- addTickLHsBinds binds - return $ L pos $ bind { abs_binds = binds' } + return $ L pos $ XHsBindsLR $ bind { abs_binds = binds' } where -- in AbsBinds, the Id on each binding is not the actual top-level -- Id that we are defining, they are related by the abs_exports diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index c4dc64e58c..c9e6ef050d 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -143,7 +143,7 @@ ds_val_bind (NonRecursive, hsbinds) body ; dsUnliftedBind bind body } where - is_polymorphic (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs }) + is_polymorphic (XHsBindsLR (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs })) = not (null tvs && null evs) is_polymorphic _ = False @@ -177,10 +177,10 @@ ds_val_bind (is_rec, binds) body ------------------ dsUnliftedBind :: HsBind GhcTc -> CoreExpr -> DsM CoreExpr -dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = [] - , abs_exports = exports - , abs_ev_binds = ev_binds - , abs_binds = lbinds }) body +dsUnliftedBind (XHsBindsLR (AbsBinds { abs_tvs = [], abs_ev_vars = [] + , abs_exports = exports + , abs_ev_binds = ev_binds + , abs_binds = lbinds })) body = do { let body1 = foldr bind_export body exports bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b ; body2 <- foldlM (\body lbind -> dsUnliftedBind (unLoc lbind) body) diff --git a/compiler/GHC/HsToCore/Pmc/Desugar.hs b/compiler/GHC/HsToCore/Pmc/Desugar.hs index 7cba784245..38d3fd54d7 100644 --- a/compiler/GHC/HsToCore/Pmc/Desugar.hs +++ b/compiler/GHC/HsToCore/Pmc/Desugar.hs @@ -388,12 +388,13 @@ desugarLocalBinds (HsValBinds _ (XValBindsLR (NValBinds binds _))) = , GRHSs{grhssGRHSs = [L _ (GRHS _ _grds rhs)]} <- grhss = do core_rhs <- dsLExpr rhs return [PmLet x core_rhs] - go (L _ AbsBinds{ abs_tvs = [], abs_ev_vars = [] - , abs_exports=exports, abs_binds = binds }) = do + go (L _ (XHsBindsLR (AbsBinds + { abs_tvs = [], abs_ev_vars = [] + , abs_exports=exports, abs_binds = binds }))) = do -- Typechecked HsLocalBinds are wrapped in AbsBinds, which carry -- renamings. See Note [Long-distance information for HsLocalBinds] -- for the details. - let go_export :: ABExport GhcTc -> Maybe PmGrd + let go_export :: ABExport -> Maybe PmGrd go_export ABE{abe_poly = x, abe_mono = y, abe_wrap = wrap} | isIdHsWrapper wrap = assertPpr (idType x `eqType` idType y) diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index 5c95f14341..34282ec363 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -1911,7 +1911,6 @@ rep_bind (L _ (VarBind { var_id = v, var_rhs = e})) ; ans <- repVal patcore x empty_decls ; return (srcLocSpan (getSrcLoc v), ans) } -rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds" rep_bind (L loc (PatSynBind _ (PSB { psb_id = syn , psb_args = args , psb_def = pat diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index 7b4e8bc20e..b6be92301f 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -267,12 +267,11 @@ instance ModifyState Id where addSubstitution mono poly hs = hs{name_remapping = extendNameEnv (name_remapping hs) (varName mono) poly} -modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState +modifyState :: [ABExport] -> HieState -> HieState modifyState = foldr go id where go ABE{abe_poly=poly,abe_mono=mono} f = addSubstitution mono poly . f - go _ f = f type HieM = ReaderT NodeOrigin (State HieState) @@ -847,21 +846,27 @@ instance HiePass p => ToHie (BindContext (LocatedA (HsBind (GhcPass p)))) where VarBind{var_rhs = expr} -> [ toHie expr ] - AbsBinds{ abs_exports = xs, abs_binds = binds - , abs_ev_binds = ev_binds - , abs_ev_vars = ev_vars } -> - [ lift (modify (modifyState xs)) >> -- Note [Name Remapping] - (toHie $ fmap (BC context scope) binds) - , toHie $ map (L span . abe_wrap) xs - , toHie $ - map (EvBindContext (mkScopeA span) (getRealSpanA span) - . L span) ev_binds - , toHie $ - map (C (EvidenceVarBind EvSigBind - (mkScopeA span) - (getRealSpanA span)) - . L span) ev_vars - ] + XHsBindsLR ext -> case hiePass @p of +#if __GLASGOW_HASKELL__ < 811 + HieRn -> dataConCantHappen ext +#endif + HieTc + | AbsBinds{ abs_exports = xs, abs_binds = binds + , abs_ev_binds = ev_binds + , abs_ev_vars = ev_vars } <- ext + -> + [ lift (modify (modifyState xs)) >> -- Note [Name Remapping] + (toHie $ fmap (BC context scope) binds) + , toHie $ map (L span . abe_wrap) xs + , toHie $ + map (EvBindContext (mkScopeA span) (getRealSpanA span) + . L span) ev_binds + , toHie $ + map (C (EvidenceVarBind EvSigBind + (mkScopeA span) + (getRealSpanA span)) + . L span) ev_vars + ] PatSynBind _ psb -> [ toHie $ L (locA span) psb -- PatSynBinds only occur at the top level ] diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index 406cb87b24..f6e71f57cf 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} @@ -268,7 +269,7 @@ instance Diagnostic TcRnMessage where 2 (vcat $ map pprLBind . bagToList $ binds) where pprLoc loc = parens (text "defined at" <+> ppr loc) - pprLBind :: GenLocated (SrcSpanAnn' a) (HsBindLR GhcRn idR) -> SDoc + pprLBind :: CollectPass GhcRn => GenLocated (SrcSpanAnn' a) (HsBindLR GhcRn idR) -> SDoc pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders CollNoDictBinders bind) <+> pprLoc (locA loc) TcRnPartialTypeSigTyVarMismatch n1 n2 fn_name hs_ty diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs index fb5d98b457..a14ff790fa 100644 --- a/compiler/GHC/Tc/Gen/Bind.hs +++ b/compiler/GHC/Tc/Gen/Bind.hs @@ -637,15 +637,13 @@ tcPolyCheck prag_fn , fun_ext = wrap_gen <.> wrap_res , fun_tick = tick } - export = ABE { abe_ext = noExtField - , abe_wrap = idHsWrapper + export = ABE { abe_wrap = idHsWrapper , abe_poly = poly_id , abe_mono = poly_id2 , abe_prags = SpecPrags spec_prags } - abs_bind = L bind_loc $ - AbsBinds { abs_ext = noExtField - , abs_tvs = [] + abs_bind = L bind_loc $ XHsBindsLR $ + AbsBinds { abs_tvs = [] , abs_ev_vars = [] , abs_ev_binds = [] , abs_exports = [export] @@ -732,9 +730,8 @@ tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list ; loc <- getSrcSpanM ; let poly_ids = map abe_poly exports - abs_bind = L (noAnnSrcSpan loc) $ - AbsBinds { abs_ext = noExtField - , abs_tvs = qtvs + abs_bind = L (noAnnSrcSpan loc) $ XHsBindsLR $ + AbsBinds { abs_tvs = qtvs , abs_ev_vars = givens, abs_ev_binds = [ev_binds] , abs_exports = exports, abs_binds = binds' , abs_sig = False } @@ -750,7 +747,7 @@ mkExport :: TcPragEnv -- when typechecking the bindings -> [TyVar] -> TcThetaType -- Both already zonked -> MonoBindInfo - -> TcM (ABExport GhcTc) + -> TcM ABExport -- Only called for generalisation plan InferGen, not by CheckGen or NoGen -- -- mkExport generates exports with @@ -803,8 +800,7 @@ mkExport prag_fn residual insoluble qtvs theta ; localSigWarn poly_id mb_sig - ; return (ABE { abe_ext = noExtField - , abe_wrap = wrap + ; return (ABE { abe_wrap = wrap -- abe_wrap :: (forall qtvs. theta => mono_ty) ~ idType poly_id , abe_poly = poly_id , abe_mono = mono_id diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs index 2f55a9cea1..ee41b3e0aa 100644 --- a/compiler/GHC/Tc/TyCl/Class.hs +++ b/compiler/GHC/Tc/TyCl/Class.hs @@ -304,13 +304,12 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn tcPolyCheck no_prag_fn local_dm_sig (L bind_loc lm_bind) - ; let export = ABE { abe_ext = noExtField - , abe_poly = global_dm_id + ; let export = ABE { abe_poly = global_dm_id , abe_mono = local_dm_id , abe_wrap = idHsWrapper , abe_prags = IsDefaultMethod } - full_bind = AbsBinds { abs_ext = noExtField - , abs_tvs = tyvars + full_bind = XHsBindsLR $ + AbsBinds { abs_tvs = tyvars , abs_ev_vars = [this_dict] , abs_exports = [export] , abs_ev_binds = [ev_binds] diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs index 699c50c54b..36a58d760a 100644 --- a/compiler/GHC/Tc/TyCl/Instance.hs +++ b/compiler/GHC/Tc/TyCl/Instance.hs @@ -1321,14 +1321,13 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) -- Newtype dfuns just inline unconditionally, -- so don't attempt to specialise them - export = ABE { abe_ext = noExtField - , abe_wrap = idHsWrapper + export = ABE { abe_wrap = idHsWrapper , abe_poly = dfun_id_w_prags , abe_mono = self_dict , abe_prags = dfun_spec_prags } -- NB: see Note [SPECIALISE instance pragmas] - main_bind = AbsBinds { abs_ext = noExtField - , abs_tvs = inst_tyvars + main_bind = XHsBindsLR $ + AbsBinds { abs_tvs = inst_tyvars , abs_ev_vars = dfun_ev_vars , abs_exports = [export] , abs_ev_binds = [] @@ -1475,14 +1474,13 @@ tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds sc_theta ; let sc_top_ty = mkInfForAllTys tyvars $ mkPhiTy (map idType dfun_evs) sc_pred sc_top_id = mkLocalId sc_top_name Many sc_top_ty - export = ABE { abe_ext = noExtField - , abe_wrap = idHsWrapper + export = ABE { abe_wrap = idHsWrapper , abe_poly = sc_top_id , abe_mono = sc_ev_id , abe_prags = noSpecPrags } local_ev_binds = TcEvBinds ev_binds_var - bind = AbsBinds { abs_ext = noExtField - , abs_tvs = tyvars + bind = XHsBindsLR $ + AbsBinds { abs_tvs = tyvars , abs_ev_vars = dfun_evs , abs_exports = [export] , abs_ev_binds = [dfun_ev_binds, local_ev_binds] @@ -1910,15 +1908,14 @@ tcMethodBody clas tyvars dfun_ev_vars inst_tys ; spec_prags <- tcSpecPrags global_meth_id prags ; let specs = mk_meth_spec_prags global_meth_id spec_inst_prags spec_prags - export = ABE { abe_ext = noExtField - , abe_poly = global_meth_id + export = ABE { abe_poly = global_meth_id , abe_mono = local_meth_id , abe_wrap = idHsWrapper , abe_prags = specs } local_ev_binds = TcEvBinds ev_binds_var - full_bind = AbsBinds { abs_ext = noExtField - , abs_tvs = tyvars + full_bind = XHsBindsLR $ + AbsBinds { abs_tvs = tyvars , abs_ev_vars = dfun_ev_vars , abs_exports = [export] , abs_ev_binds = [dfun_ev_binds, local_ev_binds] @@ -1968,14 +1965,13 @@ tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind ; (tc_bind, [inner_id]) <- tcPolyCheck no_prag_fn inner_meth_sig meth_bind - ; let export = ABE { abe_ext = noExtField - , abe_poly = local_meth_id + ; let export = ABE { abe_poly = local_meth_id , abe_mono = inner_id , abe_wrap = hs_wrap , abe_prags = noSpecPrags } - ; return (unitBag $ L (getLoc meth_bind) $ - AbsBinds { abs_ext = noExtField, abs_tvs = [], abs_ev_vars = [] + ; return (unitBag $ L (getLoc meth_bind) $ XHsBindsLR $ + AbsBinds { abs_tvs = [], abs_ev_vars = [] , abs_exports = [export] , abs_binds = tc_bind, abs_ev_binds = [] , abs_sig = True }) } diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs index ba6c98905f..197a8d8104 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -561,12 +561,12 @@ zonk_bind env bind@(FunBind { fun_id = L loc var , fun_matches = new_ms , fun_ext = new_co_fn }) } -zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs - , abs_ev_binds = ev_binds - , abs_exports = exports - , abs_binds = val_binds - , abs_sig = has_sig }) - = assert (all isImmutableTyVar tyvars) $ +zonk_bind env (XHsBindsLR (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs + , abs_ev_binds = ev_binds + , abs_exports = exports + , abs_binds = val_binds + , abs_sig = has_sig })) + = assert ( all isImmutableTyVar tyvars ) $ do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars ; (env1, new_evs) <- zonkEvBndrsX env0 evs ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds @@ -576,11 +576,11 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs ; new_val_binds <- mapBagM (zonk_val_bind env3) val_binds ; new_exports <- mapM (zonk_export env3) exports ; return (new_val_binds, new_exports) } - ; return (AbsBinds { abs_ext = noExtField - , abs_tvs = new_tyvars, abs_ev_vars = new_evs + ; return $ XHsBindsLR $ + AbsBinds { abs_tvs = new_tyvars, abs_ev_vars = new_evs , abs_ev_binds = new_ev_binds , abs_exports = new_exports, abs_binds = new_val_bind - , abs_sig = has_sig }) } + , abs_sig = has_sig } } where zonk_val_bind env lbind | has_sig @@ -599,17 +599,15 @@ zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs | otherwise = zonk_lbind env lbind -- The normal case - zonk_export :: ZonkEnv -> ABExport GhcTc -> TcM (ABExport GhcTc) - zonk_export env (ABE{ abe_ext = x - , abe_wrap = wrap + zonk_export :: ZonkEnv -> ABExport -> TcM ABExport + zonk_export env (ABE{ abe_wrap = wrap , abe_poly = poly_id , abe_mono = mono_id , abe_prags = prags }) = do new_poly_id <- zonkIdBndr env poly_id (_, new_wrap) <- zonkCoFn env wrap new_prags <- zonkSpecPrags env prags - return (ABE{ abe_ext = x - , abe_wrap = new_wrap + return (ABE{ abe_wrap = new_wrap , abe_poly = new_poly_id , abe_mono = zonkIdOcc env mono_id , abe_prags = new_prags }) diff --git a/compiler/Language/Haskell/Syntax/Binds.hs b/compiler/Language/Haskell/Syntax/Binds.hs index 183fce9836..c50eb7e833 100644 --- a/compiler/Language/Haskell/Syntax/Binds.hs +++ b/compiler/Language/Haskell/Syntax/Binds.hs @@ -1,5 +1,4 @@ {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -34,11 +33,8 @@ import {-# SOURCE #-} Language.Haskell.Syntax.Pat import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Type import GHC.Types.Name.Reader(RdrName) -import GHC.Tc.Types.Evidence -import GHC.Core.Type import GHC.Types.Basic import GHC.Types.SourceText -import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Tickish import GHC.Types.Var import GHC.Types.Fixity @@ -48,7 +44,6 @@ import GHC.Data.BooleanFormula (LBooleanFormula) import GHC.Utils.Outputable import GHC.Utils.Panic (pprPanic) -import Data.Data hiding ( Fixity ) import Data.Void {- @@ -245,28 +240,6 @@ data HsBindLR idL idR var_rhs :: LHsExpr idR -- ^ Located only for consistency } - -- | Abstraction Bindings - | AbsBinds { -- Binds abstraction; TRANSLATION - abs_ext :: XAbsBinds idL idR, - 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 idL], - - -- | 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 idL, - - abs_sig :: Bool -- See Note [The abs_sig field of AbsBinds] - } - -- | Patterns Synonym Binding | PatSynBind (XPatSynBind idL idR) @@ -281,30 +254,6 @@ data HsBindLR idL idR | XHsBindsLR !(XXHsBindsLR idL idR) - -- 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 p - = ABE { abe_ext :: XABE p - , abe_poly :: IdP p -- ^ Any INLINE pragma is attached to this Id - , abe_mono :: IdP p - , abe_wrap :: HsWrapper -- ^ See Note [ABExport wrapper] - -- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly - , abe_prags :: TcSpecPrags -- ^ SPECIALISE pragmas - } - | XABExport !(XXABExport p) - - -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnPattern', -- 'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnLarrow', -- 'GHC.Parser.Annotation.AnnWhere','GHC.Parser.Annotation.AnnOpen' @'{'@, @@ -322,214 +271,6 @@ data PatSynBind idL idR } | XPatSynBind !(XXPatSynBind idL idR) -{- -Note [AbsBinds] -~~~~~~~~~~~~~~~ -The AbsBinds constructor is used in the output of the type checker, to -record *typechecked* and *generalised* bindings. Specifically - - AbsBinds { abs_tvs = tvs - , abs_ev_vars = [d1,d2] - , abs_exports = [ABE { abe_poly = fp, abe_mono = fm - , abe_wrap = fwrap } - ABE { slly for g } ] - , abs_ev_binds = DBINDS - , abs_binds = BIND[fm,gm] } - -where 'BIND' binds the monomorphic Ids 'fm' and 'gm', means - - fp = fwrap [/\ tvs. \d1 d2. letrec { DBINDS ] - [ ; BIND[fm,gm] } ] - [ in fm ] - - gp = ...same again, with gm instead of fm - -The 'fwrap' is an impedance-matcher that typically does nothing; see -Note [ABExport wrapper]. - -This is a pretty bad translation, because it duplicates all the bindings. -So the desugarer tries to do a better job: - - fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of - (fm,gm) -> fm - ..ditto for gp.. - - tp = /\ [a,b] -> \ [d1,d2] -> letrec { DBINDS; BIND } - in (fm,gm) - -In general: - - * abs_tvs are the type variables over which the binding group is - generalised - * abs_ev_var are the evidence variables (usually dictionaries) - over which the binding group is generalised - * abs_binds are the monomorphic bindings - * abs_ex_binds are the evidence bindings that wrap the abs_binds - * abs_exports connects the monomorphic Ids bound by abs_binds - with the polymorphic Ids bound by the AbsBinds itself. - -For example, consider a module M, with this top-level binding, where -there is no type signature for M.reverse, - M.reverse [] = [] - M.reverse (x:xs) = M.reverse xs ++ [x] - -In Hindley-Milner, a recursive binding is typechecked with the -*recursive* uses being *monomorphic*. So after typechecking *and* -desugaring we will get something like this - - M.reverse :: forall a. [a] -> [a] - = /\a. letrec - reverse :: [a] -> [a] = \xs -> case xs of - [] -> [] - (x:xs) -> reverse xs ++ [x] - in reverse - -Notice that 'M.reverse' is polymorphic as expected, but there is a local -definition for plain 'reverse' which is *monomorphic*. The type variable -'a' scopes over the entire letrec. - -That's after desugaring. What about after type checking but before -desugaring? That's where AbsBinds comes in. It looks like this: - - AbsBinds { abs_tvs = [a] - , abs_ev_vars = [] - , abs_exports = [ABE { abe_poly = M.reverse :: forall a. [a] -> [a], - , abe_mono = reverse :: [a] -> [a]}] - , abs_ev_binds = {} - , abs_binds = { reverse :: [a] -> [a] - = \xs -> case xs of - [] -> [] - (x:xs) -> reverse xs ++ [x] } } - -Here, - - * abs_tvs says what type variables are abstracted over the binding - group, just 'a' in this case. - * abs_binds is the *monomorphic* bindings of the group - * abs_exports describes how to get the polymorphic Id 'M.reverse' - from the monomorphic one 'reverse' - -Notice that the *original* function (the polymorphic one you thought -you were defining) appears in the abe_poly field of the -abs_exports. The bindings in abs_binds are for fresh, local, Ids with -a *monomorphic* Id. - -If there is a group of mutually recursive (see Note [Polymorphic -recursion]) functions without type signatures, we get one AbsBinds -with the monomorphic versions of the bindings in abs_binds, and one -element of abe_exports for each variable bound in the mutually -recursive group. This is true even for pattern bindings. Example: - (f,g) = (\x -> x, f) -After type checking we get - AbsBinds { abs_tvs = [a] - , abs_exports = [ ABE { abe_poly = M.f :: forall a. a -> a - , abe_mono = f :: a -> a } - , ABE { abe_poly = M.g :: forall a. a -> a - , abe_mono = g :: a -> a }] - , abs_binds = { (f,g) = (\x -> x, f) } - -Note [Polymorphic recursion] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - Rec { f x = ...(g ef)... - - ; g :: forall a. [a] -> [a] - ; g y = ...(f eg)... } - -These bindings /are/ mutually recursive (f calls g, and g calls f). -But we can use the type signature for g to break the recursion, -like this: - - 1. Add g :: forall a. [a] -> [a] to the type environment - - 2. Typecheck the definition of f, all by itself, - including generalising it to find its most general - type, say f :: forall b. b -> b -> [b] - - 3. Extend the type environment with that type for f - - 4. Typecheck the definition of g, all by itself, - checking that it has the type claimed by its signature - -Steps 2 and 4 each generate a separate AbsBinds, so we end -up with - Rec { AbsBinds { ...for f ... } - ; AbsBinds { ...for g ... } } - -This approach allows both f and to call each other -polymorphically, even though only g has a signature. - -We get an AbsBinds that encompasses multiple source-program -bindings only when - * Each binding in the group has at least one binder that - lacks a user type signature - * The group forms a strongly connected component - - -Note [The abs_sig field of AbsBinds] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The abs_sig field supports a couple of special cases for bindings. -Consider - - x :: Num a => (# a, a #) - x = (# 3, 4 #) - -The general desugaring for AbsBinds would give - - x = /\a. \ ($dNum :: Num a) -> - letrec xm = (# fromInteger $dNum 3, fromInteger $dNum 4 #) in - xm - -But that has an illegal let-binding for an unboxed tuple. In this -case we'd prefer to generate the (more direct) - - x = /\ a. \ ($dNum :: Num a) -> - (# fromInteger $dNum 3, fromInteger $dNum 4 #) - -A similar thing happens with representation-polymorphic defns -(#11405): - - undef :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => a - undef = error "undef" - -Again, the vanilla desugaring gives a local let-binding for a -representation-polymorphic (undefm :: a), which is illegal. But -again we can desugar without a let: - - undef = /\ a. \ (d:HasCallStack) -> error a d "undef" - -The abs_sig field supports this direct desugaring, with no local -let-binding. When abs_sig = True - - * the abs_binds is single FunBind - - * the abs_exports is a singleton - - * we have a complete type sig for binder - and hence the abs_binds is non-recursive - (it binds the mono_id but refers to the poly_id - -These properties are exploited in GHC.HsToCore.Binds.dsAbsBinds to -generate code without a let-binding. - -Note [ABExport wrapper] -~~~~~~~~~~~~~~~~~~~~~~~ -Consider - (f,g) = (\x.x, \y.y) -This ultimately desugars to something like this: - tup :: forall a b. (a->a, b->b) - tup = /\a b. (\x:a.x, \y:b.y) - f :: forall a. a -> a - f = /\a. case tup a Any of - (fm::a->a,gm:Any->Any) -> fm - ...similarly for g... - -The abe_wrap field deals with impedance-matching between - (/\a b. case tup a b of { (f,g) -> f }) -and the thing we really want, which may have fewer type -variables. The action happens in GHC.Tc.Gen.Bind.mkExport. --} - {- ************************************************************************ @@ -742,39 +483,6 @@ type LFixitySig pass = XRec pass (FixitySig pass) data FixitySig pass = FixitySig (XFixitySig pass) [LIdP pass] Fixity | XFixitySig !(XXFixitySig pass) --- | 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 - isFixityLSig :: forall p. UnXRec p => LSig p -> Bool isFixityLSig (unXRec @p -> FixSig {}) = True isFixityLSig _ = False diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs index 0abd64d0d8..92cf9d5f20 100644 --- a/compiler/Language/Haskell/Syntax/Expr.hs +++ b/compiler/Language/Haskell/Syntax/Expr.hs @@ -1616,9 +1616,6 @@ data HsSplicedThing id | HsSplicedPat (Pat id) -- ^ Haskell Spliced Pattern --- See Note [Pending Splices] -type SplicePointName = Name - data UntypedSpliceFlavour = UntypedExpSplice | UntypedPatSplice diff --git a/compiler/Language/Haskell/Syntax/Extension.hs b/compiler/Language/Haskell/Syntax/Extension.hs index 6a33787d87..862c212c90 100644 --- a/compiler/Language/Haskell/Syntax/Extension.hs +++ b/compiler/Language/Haskell/Syntax/Extension.hs @@ -191,14 +191,9 @@ type family XXValBindsLR x x' type family XFunBind x x' type family XPatBind x x' type family XVarBind x x' -type family XAbsBinds x x' type family XPatSynBind x x' type family XXHsBindsLR x x' --- ABExport type families -type family XABE x -type family XXABExport x - -- PatSynBind type families type family XPSB x x' type family XXPatSynBind x x' diff --git a/testsuite/tests/ghc-api/T6145.hs b/testsuite/tests/ghc-api/T6145.hs index 392c318768..f9dbfff86c 100644 --- a/testsuite/tests/ghc-api/T6145.hs +++ b/testsuite/tests/ghc-api/T6145.hs @@ -37,7 +37,7 @@ main = do removeFile "Test.hs" print ok where - isDataCon (L _ (AbsBinds { abs_binds = bs })) + isDataCon (L _ (XHsBindsLR (AbsBinds { abs_binds = bs }))) = not (isEmptyBag (filterBag isDataCon bs)) isDataCon (L l (f@FunBind {})) | (MG _ (L _ (m:_)) _) <- fun_matches f, diff --git a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr index de44e14add..59b4113c1b 100644 --- a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr @@ -1514,92 +1514,91 @@ (HsTok)))))))) ,(L (SrcSpanAnn (EpAnnNotUsed) { DumpTypecheckedAst.hs:19:1-23 }) - (AbsBinds - (NoExtField) - [] - [] - [(ABE - (NoExtField) - {Var: main} - {Var: main} - (WpHole) - (SpecPrags - []))] - [({abstract:TcEvBinds})] - {Bag(LocatedA (HsBind Var)): - [(L - (SrcSpanAnn (EpAnn - (Anchor - { DumpTypecheckedAst.hs:19:1-23 } - (UnchangedAnchor)) - (AnnListItem - []) - (EpaComments - [])) { DumpTypecheckedAst.hs:19:1-23 }) - (FunBind - (WpHole) - (L - (SrcSpanAnn (EpAnnNotUsed) { DumpTypecheckedAst.hs:19:1-4 }) - {Var: main}) - (MG - (MatchGroupTc - [] - (TyConApp - ({abstract:TyCon}) - [(TyConApp - ({abstract:TyCon}) - [])])) + (XHsBindsLR + (AbsBinds + [] + [] + [(ABE + {Var: main} + {Var: main} + (WpHole) + (SpecPrags + []))] + [({abstract:TcEvBinds})] + {Bag(LocatedA (HsBind Var)): + [(L + (SrcSpanAnn (EpAnn + (Anchor + { DumpTypecheckedAst.hs:19:1-23 } + (UnchangedAnchor)) + (AnnListItem + []) + (EpaComments + [])) { DumpTypecheckedAst.hs:19:1-23 }) + (FunBind + (WpHole) (L - (SrcSpanAnn (EpAnnNotUsed) { DumpTypecheckedAst.hs:19:1-23 }) - [(L - (SrcSpanAnn (EpAnnNotUsed) { DumpTypecheckedAst.hs:19:1-23 }) - (Match - (EpAnnNotUsed) - (FunRhs - (L - (SrcSpanAnn (EpAnnNotUsed) { DumpTypecheckedAst.hs:19:1-4 }) - {Var: main}) - (Prefix) - (NoSrcStrict)) - [] - (GRHSs - (EpaComments - []) - [(L - (SrcSpanAnn - (EpAnnNotUsed) - { DumpTypecheckedAst.hs:19:6-23 }) - (GRHS - (EpAnnNotUsed) - [] - (L - (SrcSpanAnn (EpAnnNotUsed) { DumpTypecheckedAst.hs:19:8-23 }) - (HsApp - (EpAnnNotUsed) - (L - (SrcSpanAnn (EpAnnNotUsed) { DumpTypecheckedAst.hs:19:8-15 }) - (HsVar - (NoExtField) - (L - (SrcSpanAnn (EpAnnNotUsed) { <no location info> }) - {Var: putStrLn}))) - (L - (SrcSpanAnn (EpAnnNotUsed) { DumpTypecheckedAst.hs:19:17-23 }) - (HsLit - (EpAnn - (Anchor - { DumpTypecheckedAst.hs:19:17-23 } - (UnchangedAnchor)) - (NoEpAnns) - (EpaComments - [])) - (HsString - (SourceText "hello") - {FastString: "hello"})))))))] - (EmptyLocalBinds - (NoExtField)))))]) - (FromSource)) - []))]} - (False)))]} + (SrcSpanAnn (EpAnnNotUsed) { DumpTypecheckedAst.hs:19:1-4 }) + {Var: main}) + (MG + (MatchGroupTc + [] + (TyConApp + ({abstract:TyCon}) + [(TyConApp + ({abstract:TyCon}) + [])])) + (L + (SrcSpanAnn (EpAnnNotUsed) { DumpTypecheckedAst.hs:19:1-23 }) + [(L + (SrcSpanAnn (EpAnnNotUsed) { DumpTypecheckedAst.hs:19:1-23 }) + (Match + (EpAnnNotUsed) + (FunRhs + (L + (SrcSpanAnn (EpAnnNotUsed) { DumpTypecheckedAst.hs:19:1-4 }) + {Var: main}) + (Prefix) + (NoSrcStrict)) + [] + (GRHSs + (EpaComments + []) + [(L + (SrcSpanAnn + (EpAnnNotUsed) + { DumpTypecheckedAst.hs:19:6-23 }) + (GRHS + (EpAnnNotUsed) + [] + (L + (SrcSpanAnn (EpAnnNotUsed) { DumpTypecheckedAst.hs:19:8-23 }) + (HsApp + (EpAnnNotUsed) + (L + (SrcSpanAnn (EpAnnNotUsed) { DumpTypecheckedAst.hs:19:8-15 }) + (HsVar + (NoExtField) + (L + (SrcSpanAnn (EpAnnNotUsed) { <no location info> }) + {Var: putStrLn}))) + (L + (SrcSpanAnn (EpAnnNotUsed) { DumpTypecheckedAst.hs:19:17-23 }) + (HsLit + (EpAnn + (Anchor + { DumpTypecheckedAst.hs:19:17-23 } + (UnchangedAnchor)) + (NoEpAnns) + (EpaComments + [])) + (HsString + (SourceText "hello") + {FastString: "hello"})))))))] + (EmptyLocalBinds + (NoExtField)))))]) + (FromSource)) + []))]} + (False))))]} diff --git a/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs b/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs index dfbed9e490..a56fc3cf4f 100644 --- a/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs +++ b/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs @@ -48,7 +48,7 @@ typecheckPlugin [name, "typecheck"] _ tc } where notNamedAs name (L _ FunBind { fun_id = L _ fid }) = occNameString (getOccName fid) /= name - notNamedAs name (L _ AbsBinds { abs_binds = bnds }) + notNamedAs name (L _ (XHsBindsLR (AbsBinds { abs_binds = bnds }))) = all (notNamedAs name) bnds notNamedAs _ (L _ b) = True typecheckPlugin _ _ tc = return tc diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs index c8f50ae793..3fb283e1ff 100644 --- a/utils/check-exact/ExactPrint.hs +++ b/utils/check-exact/ExactPrint.hs @@ -1298,7 +1298,6 @@ instance ExactPrint (HsBind GhcPs) where getAnnotationEntry FunBind{} = NoEntryVal getAnnotationEntry PatBind{} = NoEntryVal getAnnotationEntry VarBind{} = NoEntryVal - getAnnotationEntry AbsBinds{} = NoEntryVal getAnnotationEntry PatSynBind{} = NoEntryVal exact (FunBind _ _ matches _) = do diff --git a/utils/haddock b/utils/haddock -Subproject 5d14361971ec6e6c3dfca282e4b80b307087afe +Subproject e057bfc880d98fe872e3ee9291d2ee1cd3ceecc |