diff options
| author | Harry Garrood harry@garrood.me <harry@garrood.me> | 2021-04-23 20:13:29 +0100 |
|---|---|---|
| committer | Harry Garrood harry@garrood.me <harry@garrood.me> | 2021-04-23 21:08:27 +0100 |
| commit | ec28c7d74cd5c9e752231dd79dfaaa7e4f485188 (patch) | |
| tree | 5bc5205d539babdf5eb61dab4cf430a549e58738 | |
| parent | 3e2b9a87510a30436f6230d3f3222972611fa7f0 (diff) | |
| parent | 7bc7eea3897dcb8a87fdb0921f451b9bc77309f6 (diff) | |
| download | haskell-ec28c7d74cd5c9e752231dd79dfaaa7e4f485188.tar.gz | |
Merge branch 'master' into content-hash-incremental-build
111 files changed, 2600 insertions, 1829 deletions
diff --git a/compiler/GHC/CmmToLlvm/Mangler.hs b/compiler/GHC/CmmToLlvm/Mangler.hs index 805f1b8074..4313294294 100644 --- a/compiler/GHC/CmmToLlvm/Mangler.hs +++ b/compiler/GHC/CmmToLlvm/Mangler.hs @@ -43,7 +43,7 @@ llvmFixupAsm logger dflags f1 f2 = {-# SCC "llvm_mangler" #-} -- | These are the rewrites that the mangler will perform rewrites :: [Rewrite] -rewrites = [rewriteSymType, rewriteAVX] +rewrites = [rewriteSymType, rewriteAVX, rewriteCall] type Rewrite = DynFlags -> B.ByteString -> Maybe B.ByteString @@ -107,6 +107,27 @@ rewriteAVX dflags s isVmovdqa = B.isPrefixOf (B.pack "vmovdqa") isVmovap = B.isPrefixOf (B.pack "vmovap") +-- | This rewrites (tail) calls to avoid creating PLT entries for +-- functions on riscv64. The replacement will load the address from the +-- GOT, which is resolved to point to the real address of the function. +rewriteCall :: Rewrite +rewriteCall dflags l + | not isRISCV64 = Nothing + | isCall l = Just $ replaceCall "call" "jalr" "ra" l + | isTail l = Just $ replaceCall "tail" "jr" "t1" l + | otherwise = Nothing + where + isRISCV64 = platformArch (targetPlatform dflags) == ArchRISCV64 + isCall = B.isPrefixOf (B.pack "call\t") + isTail = B.isPrefixOf (B.pack "tail\t") + + replaceCall call jump reg l = + appendInsn (jump ++ "\t" ++ reg) $ removePlt $ + replaceOnce (B.pack call) (B.pack ("la\t" ++ reg ++ ",")) l + where + removePlt = replaceOnce (B.pack "@plt") (B.pack "") + appendInsn i = (`B.append` B.pack ("\n\t" ++ i)) + -- | @replaceOnce match replace bs@ replaces the first occurrence of the -- substring @match@ in @bs@ with @replace@. replaceOnce :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs index 3638b43c56..72cffdbfa9 100644 --- a/compiler/GHC/Core/Make.hs +++ b/compiler/GHC/Core/Make.hs @@ -978,7 +978,7 @@ It turned out that g didn't use the second component, and hence f doesn't use the first. But the stable-unfolding for f looks like \x. case x of MkT a b -> g ($WMkT b a) where $WMkT is the wrapper for MkT that evaluates its arguments. We -apply the same w/w split to this unfolding (see Note [Worker-wrapper +apply the same w/w split to this unfolding (see Note [Worker/wrapper for INLINEABLE functions] in GHC.Core.Opt.WorkWrap) so the template ends up like \b. let a = absentError "blah" x = MkT a b diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs index cd4c310b3a..10630c1516 100644 --- a/compiler/GHC/Core/Opt/CprAnal.hs +++ b/compiler/GHC/Core/Opt/CprAnal.hs @@ -24,16 +24,17 @@ import GHC.Types.Basic import GHC.Types.Id import GHC.Types.Id.Info import GHC.Core.DataCon -import GHC.Core.Multiplicity -import GHC.Core.Utils ( exprIsHNF, dumpIdInfoOfProgram ) -import GHC.Core.Type import GHC.Core.FamInstEnv +import GHC.Core.Multiplicity import GHC.Core.Opt.WorkWrap.Utils +import GHC.Core.TyCon +import GHC.Core.Type +import GHC.Core.Utils ( exprIsHNF, dumpIdInfoOfProgram, normSplitTyConApp_maybe ) import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Logger ( Logger, dumpIfSet_dyn, DumpFormat (..) ) import GHC.Data.Graph.UnVar -- for UnVarSet -import GHC.Data.Maybe ( isNothing ) +import GHC.Data.Maybe ( isJust ) import Control.Monad ( guard ) import Data.List ( mapAccumL ) @@ -319,10 +320,10 @@ cprAnalBind top_lvl env id rhs -- possibly trim thunk CPR info rhs_ty' -- See Note [CPR for thunks] - | stays_thunk = trimCprTy rhs_ty + | stays_thunk = trimCprTy rhs_ty -- See Note [CPR for sum types] - | returns_sum = trimCprTy rhs_ty - | otherwise = rhs_ty + | returns_local_sum = trimCprTy rhs_ty + | otherwise = rhs_ty -- See Note [Arity trimming for CPR signatures] sig = mkCprSigForArity (idArity id) rhs_ty' id' = setIdCprSig id sig @@ -334,8 +335,12 @@ cprAnalBind top_lvl env id rhs not_strict = not (isStrUsedDmd (idDemandInfo id)) -- See Note [CPR for sum types] (_, ret_ty) = splitPiTys (idType id) - not_a_prod = isNothing (splitArgType_maybe (ae_fam_envs env) ret_ty) - returns_sum = not (isTopLevel top_lvl) && not_a_prod + returns_product + | Just (tc, _, _) <- normSplitTyConApp_maybe (ae_fam_envs env) ret_ty + = isJust (tyConSingleAlgDataCon_maybe tc) + | otherwise + = False + returns_local_sum = not (isTopLevel top_lvl) && not returns_product isDataStructure :: Id -> CoreExpr -> Bool -- See Note [CPR for data structures] @@ -483,7 +488,7 @@ argCprType env arg_ty dmd = CprType 0 (go arg_ty dmd) where go ty dmd | Unbox (DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args }) ds - <- wantToUnbox (ae_fam_envs env) no_inlineable_prag ty dmd + <- wantToUnboxArg (ae_fam_envs env) MaybeArgOfInlineableFun ty dmd -- No existentials; see Note [Which types are unboxed?]) -- Otherwise we'd need to call dataConRepInstPat here and thread a -- UniqSupply. So argCprType is a bit less aggressive than it could @@ -493,11 +498,6 @@ argCprType env arg_ty dmd = CprType 0 (go arg_ty dmd) = ConCpr (dataConTag dc) (zipWith go arg_tys ds) | otherwise = topCpr - -- Rather than maintaining in AnalEnv whether we are in an INLINEABLE - -- function, we just assume that we aren't. That flag is only relevant - -- to Note [Do not unpack class dictionaries], the few unboxing - -- opportunities on dicts it prohibits are probably irrelevant to CPR. - no_inlineable_prag = False {- Note [Safe abortion in the fixed-point iteration] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -550,7 +550,7 @@ This is all done in 'extendSigEnvForArg'. Note that - * Whether or not something unboxes is decided by 'wantToUnbox', else we may + * Whether or not something unboxes is decided by 'wantToUnboxArg', else we may get over-optimistic CPR results (e.g., from \(x :: a) -> x!). * If the demand unboxes deeply, we can give the binder a /nested/ CPR diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs index b317fa5ff5..0de022a78b 100644 --- a/compiler/GHC/Core/Opt/DmdAnal.hs +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -537,10 +537,9 @@ forcesRealWorld :: FamInstEnvs -> Type -> Bool forcesRealWorld fam_envs ty | ty `eqType` realWorldStatePrimTy = True - | Just DataConPatContext{ dcpc_dc = dc, dcpc_tc_args = tc_args } - <- splitArgType_maybe fam_envs ty - , isUnboxedTupleDataCon dc - , let field_tys = dataConInstArgTys dc tc_args + | Just (tc, tc_args, _co) <- normSplitTyConApp_maybe fam_envs ty + , isUnboxedTupleTyCon tc + , let field_tys = dataConInstArgTys (tyConSingleDataCon tc) tc_args = any (eqType realWorldStatePrimTy . scaledThing) field_tys | otherwise = False @@ -1320,7 +1319,7 @@ useful semantic strictness information, so now we analyse them like any other function, and pin strictness information on them. That in turn forces us to worker/wrapper them; see -Note [Worker-wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap. +Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap. Note [Lazy and unleashable free variables] diff --git a/compiler/GHC/Core/Opt/OccurAnal.hs b/compiler/GHC/Core/Opt/OccurAnal.hs index 83c44dcec2..7efcba8cd8 100644 --- a/compiler/GHC/Core/Opt/OccurAnal.hs +++ b/compiler/GHC/Core/Opt/OccurAnal.hs @@ -2124,10 +2124,22 @@ occAnalApp env (fun, args, ticks) -- often leaves behind beta redexs like -- (\x y -> e) a1 a2 -- Here we would like to mark x,y as one-shot, and treat the whole - -- thing much like a let. We do this by pushing some True items + -- thing much like a let. We do this by pushing some OneShotLam items -- onto the context stack. !(args_uds, args') = occAnalArgs env args [] +addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv +addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args + | n_val_args > 0 + = env { occ_one_shots = replicate n_val_args OneShotLam ++ ctxt + , occ_encl = OccVanilla } + -- OccVanilla: the function part of the application + -- is no longer on OccRhs or OccScrut + | otherwise + = env + where + n_val_args = valArgCount args + {- Note [Sources of one-shot information] @@ -2407,10 +2419,6 @@ markJoinOneShots mb_join_arity bndrs b' | isId b = setOneShotLambda b | otherwise = b -addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv -addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args - = env { occ_one_shots = replicate (valArgCount args) OneShotLam ++ ctxt } - -------------------- transClosureFV :: VarEnv VarSet -> VarEnv VarSet -- If (f,g), (g,h) are in the input, then (f,h) is in the output diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index e46a5c1cc5..dfbfd30e64 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -517,7 +517,7 @@ cast! We want to transfer the pagma to $wf: It's exactly like worker/wrapper for strictness analysis: f is the wrapper and must inline like crazy $wf is the worker and must carry f's original pragma -See Note [Worker-wrapper for NOINLINE functions] in +See Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap. See #17673, #18093, #18078. diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs index db4701d45a..c5e89b2ba9 100644 --- a/compiler/GHC/Core/Opt/SpecConstr.hs +++ b/compiler/GHC/Core/Opt/SpecConstr.hs @@ -62,7 +62,7 @@ import GHC.Data.FastString import GHC.Types.Unique.FM import GHC.Utils.Monad import Control.Monad ( zipWithM ) -import Data.List (nubBy, sortBy, partition) +import Data.List (nubBy, sortBy, partition, dropWhileEnd, mapAccumL ) import GHC.Builtin.Names ( specTyConKey ) import GHC.Unit.Module import GHC.Exts( SpecConstrAnnotation(..) ) @@ -946,10 +946,13 @@ extendRecBndrs env bndrs = (env { sc_subst = subst' }, bndrs') where (subst', bndrs') = substRecBndrs (sc_subst env) bndrs +extendBndrs :: ScEnv -> [Var] -> (ScEnv, [Var]) +extendBndrs env bndrs = mapAccumL extendBndr env bndrs + extendBndr :: ScEnv -> Var -> (ScEnv, Var) -extendBndr env bndr = (env { sc_subst = subst' }, bndr') - where - (subst', bndr') = substBndr (sc_subst env) bndr +extendBndr env bndr = (env { sc_subst = subst' }, bndr') + where + (subst', bndr') = substBndr (sc_subst env) bndr extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv extendValEnv env _ Nothing = env @@ -1102,6 +1105,9 @@ data Call = Call Id [CoreArg] ValueEnv -- The arguments of the call, together with the -- env giving the constructor bindings at the call site -- We keep the function mainly for debug output + -- + -- The call is not necessarily saturated; we just put + -- in however many args are visible at the call site instance Outputable ScUsage where ppr (SCU { scu_calls = calls, scu_occs = occs }) @@ -1399,12 +1405,6 @@ scTopBindEnv env (NonRec bndr rhs) ---------------------- scTopBind :: ScEnv -> ScUsage -> CoreBind -> UniqSM (ScUsage, CoreBind) -{- -scTopBind _ usage _ - | pprTrace "scTopBind_usage" (ppr (scu_calls usage)) False - = error "false" --} - scTopBind env body_usage (Rec prs) | Just threshold <- sc_size env , not force_spec @@ -1603,15 +1603,9 @@ specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs = -- pprTrace "specialise bot" (ppr fn) $ return (nullUsage, spec_info) - | isNeverActive (idInlineActivation fn) -- See Note [Transfer activation] - || null arg_bndrs -- Only specialise functions - = -- pprTrace "specialise inactive" (ppr fn) $ - case mb_unspec of -- Behave as if there was a single, boring call - Just rhs_usg -> return (rhs_usg, spec_info { si_mb_unspec = Nothing }) - -- See Note [spec_usg includes rhs_usg] - Nothing -> return (nullUsage, spec_info) - - | Just all_calls <- lookupVarEnv bind_calls fn + | not (isNeverActive (idInlineActivation fn)) -- See Note [Transfer activation] + , not (null arg_bndrs) -- Only specialise functions + , Just all_calls <- lookupVarEnv bind_calls fn -- Some calls to it = -- pprTrace "specialise entry {" (ppr fn <+> ppr all_calls) $ do { (boring_call, new_pats) <- callsToNewPats env fn spec_info arg_occs all_calls @@ -1650,10 +1644,13 @@ specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs , si_n_specs = spec_count + n_pats , si_mb_unspec = mb_unspec' }) } - | otherwise -- No new seeds, so return nullUsage - = return (nullUsage, spec_info) - - + | otherwise -- No calls, inactive, or not a function + -- Behave as if there was a single, boring call + = -- pprTrace "specialise inactive" (ppr fn $$ ppr mb_unspec) $ + case mb_unspec of -- Behave as if there was a single, boring call + Just rhs_usg -> return (rhs_usg, spec_info { si_mb_unspec = Nothing }) + -- See Note [spec_usg includes rhs_usg] + Nothing -> return (nullUsage, spec_info) --------------------- @@ -1686,58 +1683,70 @@ spec_one :: ScEnv f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw -} -spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number) +spec_one env fn arg_bndrs body (call_pat, rule_number) + | CP { cp_qvars = qvars, cp_args = pats } <- call_pat = do { spec_uniq <- getUniqueM - ; let spec_env = extendScSubstList (extendScInScope env qvars) - (arg_bndrs `zip` pats) - fn_name = idName fn - fn_loc = nameSrcSpan fn_name - fn_occ = nameOccName fn_name - spec_occ = mkSpecOcc fn_occ + ; let env1 = extendScSubstList (extendScInScope env qvars) + (arg_bndrs `zip` pats) + (body_env, extra_bndrs) = extendBndrs env1 (dropList pats arg_bndrs) + -- Remember, there may be fewer pats than arg_bndrs + -- See Note [SpecConstr call patterns] + + fn_name = idName fn + fn_loc = nameSrcSpan fn_name + fn_occ = nameOccName fn_name + spec_occ = mkSpecOcc fn_occ -- We use fn_occ rather than fn in the rule_name string -- as we don't want the uniq to end up in the rule, and -- hence in the ABI, as that can cause spurious ABI -- changes (#4012). rule_name = mkFastString ("SC:" ++ occNameString fn_occ ++ show rule_number) spec_name = mkInternalName spec_uniq spec_occ fn_loc --- ; pprTrace "{spec_one" (ppr (sc_count env) <+> ppr fn --- <+> ppr pats <+> text "-->" <+> ppr spec_name) $ +-- ; pprTrace "spec_one {" (vcat [ text "function:" <+> ppr fn <+> ppr (idUnique fn) +-- , text "sc_count:" <+> ppr (sc_count env) +-- , text "pats:" <+> ppr pats +-- , text "-->" <+> ppr spec_name +-- , text "bndrs" <+> ppr arg_bndrs +-- , text "body" <+> ppr body +-- , text "how_bound" <+> ppr (sc_how_bound env) ]) $ -- return () -- Specialise the body - ; (spec_usg, spec_body) <- scExpr spec_env body + ; (spec_usg, spec_body) <- scExpr body_env body --- ; pprTrace "done spec_one}" (ppr fn) $ +-- ; pprTrace "done spec_one }" (ppr fn $$ ppr (scu_calls spec_usg)) $ -- return () -- And build the results - ; let (spec_lam_args, spec_call_args) = mkWorkerArgs (sc_dflags env) - qvars body_ty - -- Usual w/w hack to avoid generating + ; let spec_body_ty = exprType spec_body + spec_lam_args1 = qvars ++ extra_bndrs + (spec_lam_args, spec_call_args) = mkWorkerArgs False + spec_lam_args1 spec_body_ty + -- mkWorkerArgs: usual w/w hack to avoid generating -- a spec_rhs of unlifted type and no args - spec_lam_args_str = handOutStrictnessInformation (fst (splitDmdSig spec_str)) spec_lam_args + spec_str = calcSpecStrictness fn spec_lam_args pats + spec_lam_args_str = handOutStrictnessInformation spec_str spec_lam_args -- Annotate the variables with the strictness information from -- the function (see Note [Strictness information in worker binders]) spec_join_arity | isJoinId fn = Just (length spec_lam_args) | otherwise = Nothing spec_id = mkLocalId spec_name Many - (mkLamTypes spec_lam_args body_ty) + (mkLamTypes spec_lam_args spec_body_ty) -- See Note [Transfer strictness] `setIdDmdSig` spec_str `setIdCprSig` topCprSig `setIdArity` count isId spec_lam_args `asJoinId_maybe` spec_join_arity - spec_str = calcSpecStrictness fn spec_lam_args pats -- Conditionally use result of new worker-wrapper transform spec_rhs = mkLams spec_lam_args_str spec_body - body_ty = exprType spec_body - rule_rhs = mkVarApps (Var spec_id) spec_call_args + rule_rhs = mkVarApps (Var spec_id) $ + dropTail (length extra_bndrs) spec_call_args inline_act = idInlineActivation fn - this_mod = sc_module spec_env + this_mod = sc_module env rule = mkRule this_mod True {- Auto -} True {- Local -} rule_name inline_act fn_name qvars pats rule_rhs -- See Note [Transfer activation] @@ -1747,8 +1756,9 @@ spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number) -- See Note [Strictness information in worker binders] -handOutStrictnessInformation :: [Demand] -> [Var] -> [Var] -handOutStrictnessInformation = go +handOutStrictnessInformation :: DmdSig -> [Var] -> [Var] +handOutStrictnessInformation str vs + = go (fst (splitDmdSig str)) vs where go _ [] = [] go [] vs = vs @@ -1757,7 +1767,7 @@ handOutStrictnessInformation = go calcSpecStrictness :: Id -- The original function -> [Var] -> [CoreExpr] -- Call pattern - -> DmdSig -- Strictness of specialised thing + -> DmdSig -- Strictness of specialised thing -- See Note [Transfer strictness] calcSpecStrictness fn qvars pats = mkClosedDmdSig spec_dmds div @@ -1871,19 +1881,39 @@ See # 5458. Yuk. Note [SpecConstr call patterns] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A "call patterns" that we collect is going to become the LHS of a RULE. -It's important that it doesn't have + +Wrinkles: + +* The list of argument patterns, cp_args, is no longer than the + visible lambdas of the binding, ri_arg_occs. This is done via + the zipWithM in callToPats. + +* The list of argument patterns can certainly be shorter than the + lambdas in the function definition (under-saturated). For example + f x y = case x of { True -> e1; False -> e2 } + ....map (f True) e... + We want to specialise `f` for `f True`. + +* In fact we deliberately shrink the list of argument patterns, + cp_args, by trimming off all the boring ones at the end (see + `dropWhileEnd is_boring` in callToPats). Since the RULE only + applies when it is saturated, this shrinking makes the RULE more + applicable. But it does mean that the argument patterns do not + necessarily saturate the lambdas of the function. + +* It's important that the pattern arguments do not look like e |> Refl -or + or e |> g1 |> g2 -because both of these will be optimised by Simplify.simplRule. In the -former case such optimisation benign, because the rule will match more -terms; but in the latter we may lose a binding of 'g1' or 'g2', and -end up with a rule LHS that doesn't bind the template variables -(#10602). + because both of these will be optimised by Simplify.simplRule. In the + former case such optimisation benign, because the rule will match more + terms; but in the latter we may lose a binding of 'g1' or 'g2', and + end up with a rule LHS that doesn't bind the template variables + (#10602). -The simplifier eliminates such things, but SpecConstr itself constructs -new terms by substituting. So the 'mkCast' in the Cast case of scExpr -is very important! + The simplifier eliminates such things, but SpecConstr itself constructs + new terms by substituting. So the 'mkCast' in the Cast case of scExpr + is very important! Note [Choosing patterns] ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1968,8 +1998,14 @@ alternative would be to discard calls that mention coercion variables only in kind-casts, but I'm doing the simple thing for now. -} -type CallPat = ([Var], [CoreExpr]) -- Quantified variables and arguments - -- See Note [SpecConstr call patterns] +data CallPat = CP { cp_qvars :: [Var] -- Quantified variables + , cp_args :: [CoreExpr] } -- Arguments + -- See Note [SpecConstr call patterns] + +instance Outputable CallPat where + ppr (CP { cp_qvars = qvars, cp_args = args }) + = text "CP" <> braces (sep [ text "cp_qvars =" <+> ppr qvars <> comma + , text "cp_args =" <+> ppr args ]) callsToNewPats :: ScEnv -> Id -> SpecInfo @@ -1995,34 +2031,40 @@ callsToNewPats env fn spec_info@(SI { si_specs = done_specs }) bndr_occs calls -- Remove ones that have too many worker variables small_pats = filterOut too_big non_dups - too_big (vars,args) = not (isWorkerSmallEnough (sc_dflags env) (valArgCount args) vars) + max_args = maxWorkerArgs (sc_dflags env) + too_big (CP { cp_qvars = vars, cp_args = args }) + = not (isWorkerSmallEnough max_args (valArgCount args) vars) -- We are about to construct w/w pair in 'spec_one'. -- Omit specialisation leading to high arity workers. -- See Note [Limit w/w arity] in GHC.Core.Opt.WorkWrap.Utils -- Discard specialisations if there are too many of them - trimmed_pats = trim_pats env fn spec_info small_pats + (pats_were_discarded, trimmed_pats) = trim_pats env fn spec_info small_pats -- ; pprTrace "callsToPats" (vcat [ text "calls to" <+> ppr fn <> colon <+> ppr calls -- , text "done_specs:" <+> ppr (map os_pat done_specs) -- , text "good_pats:" <+> ppr good_pats ]) $ -- return () - ; return (have_boring_call, trimmed_pats) } + ; return (have_boring_call || pats_were_discarded, trimmed_pats) } + -- If any of the calls does not give rise to a specialisation, either + -- because it is boring, or because there are too many specialisations, + -- return a flag to say so, so that we know to keep the original function. -trim_pats :: ScEnv -> Id -> SpecInfo -> [CallPat] -> [CallPat] +trim_pats :: ScEnv -> Id -> SpecInfo -> [CallPat] -> (Bool, [CallPat]) +-- True <=> some patterns were discarded -- See Note [Choosing patterns] trim_pats env fn (SI { si_n_specs = done_spec_count }) pats | sc_force env || isNothing mb_scc || n_remaining >= n_pats = -- pprTrace "trim_pats: no-trim" (ppr (sc_force env) $$ ppr mb_scc $$ ppr n_remaining $$ ppr n_pats) - pats -- No need to trim + (False, pats) -- No need to trim | otherwise = emit_trace $ -- Need to trim, so keep the best ones - take n_remaining sorted_pats + (True, take n_remaining sorted_pats) where n_pats = length pats @@ -2041,7 +2083,8 @@ trim_pats env fn (SI { si_n_specs = done_spec_count }) pats pat_cons :: CallPat -> Int -- How many data constructors of literals are in -- the pattern. More data-cons => less general - pat_cons (qs, ps) = foldr ((+) . n_cons) 0 ps + pat_cons (CP { cp_qvars = qs, cp_args = ps }) + = foldr ((+) . n_cons) 0 ps where q_set = mkVarSet qs n_cons (Var v) | v `elemVarSet` q_set = 0 @@ -2072,12 +2115,21 @@ callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat) -- Type variables come first, since they may scope -- over the following term variables -- The [CoreExpr] are the argument patterns for the rule -callToPats env bndr_occs call@(Call _ args con_env) - | args `ltLength` bndr_occs -- Check saturated - = return Nothing - | otherwise +callToPats env bndr_occs call@(Call fn args con_env) = do { let in_scope = substInScope (sc_subst env) - ; (interesting, pats) <- argsToPats env in_scope con_env args bndr_occs + + ; pairs <- zipWithM (argToPat env in_scope con_env) args bndr_occs + -- This zip trims the args to be no longer than + -- the lambdas in the function definition (bndr_occs) + + -- Drop boring patterns from the end + -- See Note [SpecConstr call patterns] + ; let pairs' | isJoinId fn = pairs + | otherwise = dropWhileEnd is_boring pairs + is_boring (interesting, _) = not interesting + (interesting_s, pats) = unzip pairs' + interesting = or interesting_s + ; let pat_fvs = exprsFreeVarsList pats -- To get determinism we need the list of free variables in -- deterministic order. Otherwise we end up creating @@ -2107,18 +2159,16 @@ callToPats env bndr_occs call@(Call _ args con_env) bad_covars :: CoVarSet bad_covars = mapUnionVarSet get_bad_covars pats get_bad_covars :: CoreArg -> CoVarSet - get_bad_covars (Type ty) - = filterVarSet (\v -> isId v && not (is_in_scope v)) $ - tyCoVarsOfType ty - get_bad_covars _ - = emptyVarSet + get_bad_covars (Type ty) = filterVarSet bad_covar (tyCoVarsOfType ty) + get_bad_covars _ = emptyVarSet + bad_covar v = isId v && not (is_in_scope v) ; -- pprTrace "callToPats" (ppr args $$ ppr bndr_occs) $ WARN( not (isEmptyVarSet bad_covars) , text "SpecConstr: bad covars:" <+> ppr bad_covars $$ ppr call ) if interesting && isEmptyVarSet bad_covars - then return (Just (qvars', pats)) + then return (Just (CP { cp_qvars = qvars', cp_args = pats })) else return Nothing } -- argToPat takes an actual argument, and returns an abstracted @@ -2204,10 +2254,10 @@ argToPat env in_scope val_env arg arg_occ | Just (ConVal (DataAlt dc) args) <- isValue val_env arg , not (ignoreDataCon env dc) -- See Note [NoSpecConstr] , Just arg_occs <- mb_scrut dc - = do { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args - ; (_, args') <- argsToPats env in_scope val_env rest_args arg_occs - ; return (True, - mkConApp dc (ty_args ++ args')) } + = do { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args + ; prs <- zipWithM (argToPat env in_scope val_env) rest_args arg_occs + ; let args' = map snd prs + ; return (True, mkConApp dc (ty_args ++ args')) } where mb_scrut dc = case arg_occ of ScrutOcc bs | Just occs <- lookupUFM bs dc @@ -2266,14 +2316,6 @@ wildCardPat ty ; let id = mkSysLocalOrCoVar (fsLit "sc") uniq Many ty ; return (False, varToCoreExpr id) } -argsToPats :: ScEnv -> InScopeSet -> ValueEnv - -> [CoreArg] -> [ArgOcc] -- Should be same length - -> UniqSM (Bool, [CoreArg]) -argsToPats env in_scope val_env args occs - = do { stuff <- zipWithM (argToPat env in_scope val_env) args occs - ; let (interesting_s, args') = unzip stuff - ; return (or interesting_s, args') } - isValue :: ValueEnv -> CoreExpr -> Maybe Value isValue _env (Lit lit) | litIsLifted lit = Nothing @@ -2324,7 +2366,8 @@ valueIsWorkFree LambdaVal = True valueIsWorkFree (ConVal _ args) = all exprIsWorkFree args samePat :: CallPat -> CallPat -> Bool -samePat (vs1, as1) (vs2, as2) +samePat (CP { cp_qvars = vs1, cp_args = as1 }) + (CP { cp_qvars = vs2, cp_args = as2 }) = all2 same as1 as2 where same (Var v1) (Var v2) diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs index ffb50d45c7..fc62f5fa8a 100644 --- a/compiler/GHC/Core/Opt/Specialise.hs +++ b/compiler/GHC/Core/Opt/Specialise.hs @@ -2528,7 +2528,7 @@ pragma made the program slower! The reason was that the specialised function $sinsertWith arising from the pragma looked rather like `f` above, and failed to specialise a call in its body like wimwam. Without the pragma, the original call to `insertWith` was completely -monomorpic, and speciased in one go. +monomorphic, and specialised in one go. -} instance Outputable DictBind where diff --git a/compiler/GHC/Core/Opt/WorkWrap.hs b/compiler/GHC/Core/Opt/WorkWrap.hs index 2ee334b9f8..b7a52d4571 100644 --- a/compiler/GHC/Core/Opt/WorkWrap.hs +++ b/compiler/GHC/Core/Opt/WorkWrap.hs @@ -181,7 +181,7 @@ Notice that we refrain from w/w'ing an INLINE function even if it is in a recursive group. It might not be the loop breaker. (We could test for loop-breaker-hood, but I'm not sure that ever matters.) -Note [Worker-wrapper for INLINABLE functions] +Note [Worker/wrapper for INLINABLE functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we have {-# INLINABLE f #-} @@ -226,7 +226,7 @@ in advance...the logic in mkWwBodies is complex. So I've left the super-simple test, with this Note to explain. -Note [Worker-wrapper for NOINLINE functions] +Note [Worker/wrapper for NOINLINE functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We used to disable worker/wrapper for NOINLINE things, but it turns out this can cause unnecessary reboxing of values. Consider @@ -300,7 +300,7 @@ splitting a NOINLINE function. Note [Worker activation] ~~~~~~~~~~~~~~~~~~~~~~~~ -Follows on from Note [Worker-wrapper for INLINABLE functions] +Follows on from Note [Worker/wrapper for INLINABLE functions] It is *vital* that if the worker gets an INLINABLE pragma (from the original function), then the worker has the same phase activation as @@ -413,7 +413,7 @@ When should the wrapper inlining be active? Id 2. It should be active at some point, despite (1) because of - Note [Worker-wrapper for NOINLINE functions] + Note [Worker/wrapper for NOINLINE functions] 3. For ordinary functions with no pragmas we want to inline the wrapper as early as possible (#15056). Suppose another module @@ -469,7 +469,7 @@ Note [Wrapper NoUserInlinePrag] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ We use NoUserInlinePrag on the wrapper, to say that there is no user-specified inline pragma. (The worker inherits that; see Note -[Worker-wrapper for INLINABLE functions].) The wrapper has no pragma +[Worker/wrapper for INLINABLE functions].) The wrapper has no pragma given by the user. (Historical note: we used to give the wrapper an INLINE pragma, but @@ -492,7 +492,7 @@ tryWW :: DynFlags -- if two, then a worker and a -- wrapper. tryWW dflags fam_envs is_rec fn_id rhs - -- See Note [Worker-wrapper for NOINLINE functions] + -- See Note [Worker/wrapper for NOINLINE functions] | Just stable_unf <- certainlyWillInline uf_opts fn_info = return [ (fn_id `setIdUnfolding` stable_unf, rhs) ] @@ -611,7 +611,7 @@ splitFun dflags fam_envs fn_id fn_info wrap_dmds div cpr rhs | otherwise = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr cpr) ) -- The arity should match the signature - do { mb_stuff <- mkWwBodies dflags fam_envs rhs_fvs fn_id wrap_dmds use_cpr_info + do { mb_stuff <- mkWwBodies (initWwOpts dflags fam_envs) rhs_fvs fn_id wrap_dmds use_cpr_info ; case mb_stuff of Nothing -> return [(fn_id, rhs)] @@ -658,7 +658,7 @@ mkWWBindPair dflags fn_id fn_info arity rhs work_uniq div cpr , inl_sat = Nothing , inl_act = work_act , inl_rule = FunLike } - -- inl_inline: copy from fn_id; see Note [Worker-wrapper for INLINABLE functions] + -- inl_inline: copy from fn_id; see Note [Worker/wrapper for INLINABLE functions] -- inl_act: see Note [Worker activation] -- inl_rule: it does not make sense for workers to be constructorlike. @@ -677,7 +677,7 @@ mkWWBindPair dflags fn_id fn_info arity rhs work_uniq div cpr `setInlinePragma` work_prag `setIdUnfolding` mkWorkerUnfolding simpl_opts work_fn fn_unfolding - -- See Note [Worker-wrapper for INLINABLE functions] + -- See Note [Worker/wrapper for INLINABLE functions] `setIdDmdSig` mkClosedDmdSig work_demands div -- Even though we may not be at top level, @@ -870,7 +870,8 @@ splitThunk :: DynFlags -> FamInstEnvs -> RecFlag -> Var -> Expr Var -> UniqSM [( splitThunk dflags fam_envs is_rec x rhs = ASSERT(not (isJoinId x)) do { let x' = localiseId x -- See comment above - ; (useful,_, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False [x'] + ; (useful,_, wrap_fn, work_fn) + <- mkWWstr (initWwOpts dflags fam_envs) NotArgOfInlineableFun [x'] ; let res = [ (x, Let (NonRec x' rhs) (wrap_fn (work_fn (Var x')))) ] ; if useful then ASSERT2( isNonRec is_rec, ppr x ) -- The thunk must be non-recursive return res diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs index f51e716c38..4ef35e9b83 100644 --- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs +++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs @@ -5,10 +5,12 @@ A library for the ``worker\/wrapper'' back-end to the strictness analyser -} {-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} module GHC.Core.Opt.WorkWrap.Utils - ( mkWwBodies, mkWWstr, mkWorkerArgs - , DataConPatContext(..), UnboxingDecision(..), splitArgType_maybe, wantToUnbox + ( WwOpts(..), initWwOpts, mkWwBodies, mkWWstr, mkWorkerArgs + , DataConPatContext(..) + , UnboxingDecision(..), ArgOfInlineableFun(..), wantToUnboxArg , findTypeShape , isWorkerSmallEnough ) @@ -20,16 +22,17 @@ import GHC.Prelude import GHC.Core import GHC.Core.Utils ( exprType, mkCast, mkDefaultCase, mkSingleAltCase - , bindNonRec, dataConRepFSInstPat ) + , bindNonRec, dataConRepFSInstPat + , normSplitTyConApp_maybe, exprIsHNF ) import GHC.Types.Id import GHC.Types.Id.Info ( JoinArity ) import GHC.Core.DataCon import GHC.Types.Demand import GHC.Types.Cpr -import GHC.Core.Make ( mkAbsentErrorApp, mkCoreUbxTup - , mkCoreApp, mkCoreLet ) +import GHC.Core.Make ( mkAbsentErrorApp, mkCoreUbxTup, mkCoreApp, mkCoreLet + , mkWildValBinder ) import GHC.Types.Id.Make ( voidArgId, voidPrimId ) -import GHC.Builtin.Types ( tupleDataCon ) +import GHC.Builtin.Types ( tupleDataCon ) import GHC.Types.Literal ( mkLitRubbish ) import GHC.Types.Var.Env ( mkInScopeSet ) import GHC.Types.Var.Set ( VarSet ) @@ -45,15 +48,19 @@ import GHC.Core.TyCon.RecWalk import GHC.Types.Unique.Supply import GHC.Types.Unique import GHC.Types.Name ( getOccFS ) -import GHC.Data.Maybe import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Driver.Session import GHC.Driver.Ppr import GHC.Data.FastString +import GHC.Data.OrdList import GHC.Data.List.SetOps +import Control.Applicative ( (<|>) ) +import Control.Monad ( zipWithM ) +import Data.List ( unzip4 ) + {- ************************************************************************ * * @@ -123,14 +130,34 @@ the unusable strictness-info into the interfaces. @mkWwBodies@ is called when doing the worker\/wrapper split inside a module. -} +data WwOpts + = MkWwOpts + { wo_fam_envs :: !FamInstEnvs + , wo_cpr_anal :: !Bool + , wo_fun_to_thunk :: !Bool + , wo_max_worker_args :: !Int + , wo_output_file :: Maybe String + } + +initWwOpts :: DynFlags -> FamInstEnvs -> WwOpts +initWwOpts dflags fam_envs = MkWwOpts + { wo_fam_envs = fam_envs + , wo_cpr_anal = gopt Opt_CprAnal dflags + , wo_fun_to_thunk = gopt Opt_FunToThunk dflags + , wo_max_worker_args = maxWorkerArgs dflags + , wo_output_file = outputFile dflags + } + type WwResult = ([Demand], -- Demands for worker (value) args JoinArity, -- Number of worker (type OR value) args Id -> CoreExpr, -- Wrapper body, lacking only the worker Id CoreExpr -> CoreExpr) -- Worker body, lacking the original function rhs -mkWwBodies :: DynFlags - -> FamInstEnvs +nop_fn :: CoreExpr -> CoreExpr +nop_fn body = body + +mkWwBodies :: WwOpts -> VarSet -- Free vars of RHS -- See Note [Freshen WW arguments] -> Id -- The original function @@ -149,25 +176,25 @@ mkWwBodies :: DynFlags -- let x = (a,b) in -- E -mkWwBodies dflags fam_envs rhs_fvs fun_id demands cpr_info +mkWwBodies opts rhs_fvs fun_id demands cpr_info = do { let empty_subst = mkEmptyTCvSubst (mkInScopeSet rhs_fvs) -- See Note [Freshen WW arguments] ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) <- mkWWargs empty_subst fun_ty demands ; (useful1, work_args, wrap_fn_str, work_fn_str) - <- mkWWstr dflags fam_envs has_inlineable_prag wrap_args + <- mkWWstr opts inlineable_flag wrap_args -- Do CPR w/w. See Note [Always do CPR w/w] ; (useful2, wrap_fn_cpr, work_fn_cpr, cpr_res_ty) - <- mkWWcpr (gopt Opt_CprAnal dflags) fam_envs res_ty cpr_info + <- mkWWcpr_entry opts res_ty cpr_info - ; let (work_lam_args, work_call_args) = mkWorkerArgs dflags work_args cpr_res_ty + ; let (work_lam_args, work_call_args) = mkWorkerArgs (wo_fun_to_thunk opts) work_args cpr_res_ty worker_args_dmds = [idDemandInfo v | v <- work_call_args, isId v] wrapper_body = wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var worker_body = mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args - ; if isWorkerSmallEnough dflags (length demands) work_args + ; if isWorkerSmallEnough (wo_max_worker_args opts) (length demands) work_args && not (too_many_args_for_join_point wrap_args) && ((useful1 && not only_one_void_argument) || useful2) then return (Just (worker_args_dmds, length work_call_args, @@ -184,8 +211,9 @@ mkWwBodies dflags fam_envs rhs_fvs fun_id demands cpr_info where fun_ty = idType fun_id mb_join_arity = isJoinId_maybe fun_id - has_inlineable_prag = isStableUnfolding (realIdUnfolding fun_id) - -- See Note [Do not unpack class dictionaries] + inlineable_flag -- See Note [Do not unpack class dictionaries] + | isStableUnfolding (realIdUnfolding fun_id) = MaybeArgOfInlineableFun + | otherwise = NotArgOfInlineableFun -- Note [Do not split void functions] only_one_void_argument @@ -208,9 +236,9 @@ mkWwBodies dflags fam_envs rhs_fvs fun_id demands cpr_info = False -- See Note [Limit w/w arity] -isWorkerSmallEnough :: DynFlags -> Int -> [Var] -> Bool -isWorkerSmallEnough dflags old_n_args vars - = count isId vars <= max old_n_args (maxWorkerArgs dflags) +isWorkerSmallEnough :: Int -> Int -> [Var] -> Bool +isWorkerSmallEnough max_worker_args old_n_args vars + = count isId vars <= max old_n_args max_worker_args -- We count only Free variables (isId) to skip Type, Kind -- variables which have no runtime representation. -- Also if the function took 82 arguments before (old_n_args), it's fine if @@ -274,11 +302,12 @@ add a void argument. E.g. We use the state-token type which generates no code. -} -mkWorkerArgs :: DynFlags -> [Var] +mkWorkerArgs :: Bool + -> [Var] -> Type -- Type of body -> ([Var], -- Lambda bound args [Var]) -- Args at call site -mkWorkerArgs dflags args res_ty +mkWorkerArgs fun_to_thunk args res_ty | any isId args || not needsAValueLambda = (args, args) | otherwise @@ -290,7 +319,7 @@ mkWorkerArgs dflags args res_ty -- We may encounter a levity-polymorphic result, in which case we -- conservatively assume that we have laziness that needs preservation. -- See #15186. - || not (gopt Opt_FunToThunk dflags) + || not fun_to_thunk -- see Note [Protecting the last value argument] -- Might the result be lifted? @@ -423,7 +452,7 @@ mkWWargs :: TCvSubst -- Freshening substitution to apply to the type mkWWargs subst fun_ty demands | null demands - = return ([], id, id, substTy subst fun_ty) + = return ([], nop_fn, nop_fn, substTy subst fun_ty) | (dmd:demands') <- demands , Just (mult, arg_ty, fun_ty') <- splitFunTy_maybe fun_ty @@ -466,14 +495,15 @@ mkWWargs subst fun_ty demands res_ty) } | otherwise - = WARN( True, ppr fun_ty ) -- Should not happen: if there is a demand - return ([], id, id, substTy subst fun_ty) -- then there should be a function arrow + = WARN( True, ppr fun_ty ) -- Should not happen: if there is a demand + return ([], nop_fn, nop_fn, substTy subst fun_ty) -- then there should be a function arrow where -- See Note [Join points and beta-redexes] apply_or_bind_then k arg (Lam bndr body) = mkCoreLet (NonRec bndr arg) (k body) -- Important that arg is fresh! apply_or_bind_then k arg fun = k $ mkCoreApp (text "mkWWargs") fun arg + applyToVars :: [Var] -> CoreExpr -> CoreExpr applyToVars vars fn = mkVarApps fn vars @@ -538,89 +568,53 @@ data DataConPatContext , dcpc_co :: !Coercion } --- | If @splitArgType_maybe ty = Just (dc, tys, co)@ --- then @dc \@tys \@_ex_tys (_args::_arg_tys) :: tc tys@ --- and @co :: ty ~ tc tys@ --- where underscore prefixes are holes, e.g. yet unspecified. --- --- See Note [Which types are unboxed?]. -splitArgType_maybe :: FamInstEnvs -> Type -> Maybe DataConPatContext -splitArgType_maybe fam_envs ty - | let (co, ty1) = topNormaliseType_maybe fam_envs ty - `orElse` (mkRepReflCo ty, ty) - , Just (tc, tc_args) <- splitTyConApp_maybe ty1 - , Just con <- tyConSingleAlgDataCon_maybe tc - = Just DataConPatContext { dcpc_dc = con - , dcpc_tc_args = tc_args - , dcpc_co = co } -splitArgType_maybe _ _ = Nothing - --- | If @splitResultType_maybe n ty = Just (dc, tys, co)@ --- then @dc \@tys \@_ex_tys (_args::_arg_tys) :: tc tys@ --- and @co :: ty ~ tc tys@ --- where underscore prefixes are holes, e.g. yet unspecified. --- @dc@ is the @n@th data constructor of @tc@. --- --- See Note [Which types are unboxed?]. -splitResultType_maybe :: FamInstEnvs -> ConTag -> Type -> Maybe DataConPatContext -splitResultType_maybe fam_envs con_tag ty - | let (co, ty1) = topNormaliseType_maybe fam_envs ty - `orElse` (mkRepReflCo ty, ty) - , Just (tc, tc_args) <- splitTyConApp_maybe ty1 - , isDataTyCon tc -- NB: rules out unboxed sums and pairs! - , let cons = tyConDataCons tc - , cons `lengthAtLeast` con_tag -- This might not be true if we import the - -- type constructor via a .hs-boot file (#8743) - , let con = cons `getNth` (con_tag - fIRST_TAG) - , null (dataConExTyCoVars con) -- no existentials; - -- See Note [Which types are unboxed?] - -- and GHC.Core.Opt.CprAnal.extendEnvForDataAlt - -- where we also check this. - , all isLinear (dataConInstArgTys con tc_args) - -- Deactivates CPR worker/wrapper splits on constructors with non-linear - -- arguments, for the moment, because they require unboxed tuple with variable - -- multiplicity fields. - = Just DataConPatContext { dcpc_dc = con - , dcpc_tc_args = tc_args - , dcpc_co = co } -splitResultType_maybe _ _ _ = Nothing - -isLinear :: Scaled a -> Bool -isLinear (Scaled w _ ) = - case w of - One -> True - _ -> False - -- | Describes the outer shape of an argument to be unboxed or left as-is --- Depending on how @s@ is instantiated (e.g., 'Demand'). +-- Depending on how @s@ is instantiated (e.g., 'Demand' or 'Cpr'). data UnboxingDecision s = StopUnboxing -- ^ We ran out of strictness info. Leave untouched. + | DropAbsent + -- ^ The argument/field was absent. Drop it. | Unbox !DataConPatContext [s] -- ^ The argument is used strictly or the returned product was constructed, so -- unbox it. -- The 'DataConPatContext' carries the bits necessary for -- instantiation with 'dataConRepInstPat'. -- The @[s]@ carries the bits of information with which we can continue - -- unboxing, e.g. @s@ will be 'Demand'. - -wantToUnbox :: FamInstEnvs -> Bool -> Type -> Demand -> UnboxingDecision Demand + -- unboxing, e.g. @s@ will be 'Demand' or 'Cpr'. + +-- | A specialised Bool for an argument to 'wantToUnboxArg'. +-- See Note [Do not unpack class dictionaries]. +data ArgOfInlineableFun + = NotArgOfInlineableFun -- ^ Definitely not in an inlineable fun. + | MaybeArgOfInlineableFun -- ^ We might be in an inlineable fun, so we won't + -- unbox dictionary args. + deriving Eq + +-- | Unboxing strategy for strict arguments. +wantToUnboxArg :: FamInstEnvs -> ArgOfInlineableFun -> Type -> Demand -> UnboxingDecision Demand -- See Note [Which types are unboxed?] -wantToUnbox fam_envs has_inlineable_prag ty dmd = - case splitArgType_maybe fam_envs ty of - Just dcpc@DataConPatContext{ dcpc_dc = dc } - | isStrUsedDmd dmd - , let arity = dataConRepArity dc - -- See Note [Unpacking arguments with product and polymorphic demands] - , Just cs <- split_prod_dmd_arity dmd arity - -- See Note [Do not unpack class dictionaries] - , not (has_inlineable_prag && isClassPred ty) - -- See Note [mkWWstr and unsafeCoerce] - , cs `lengthIs` arity - -- See Note [Add demands for strict constructors] - , let cs' = addDataConStrictness dc cs - -> Unbox dcpc cs' - _ -> StopUnboxing +wantToUnboxArg fam_envs inlineable_flag ty dmd + | isAbsDmd dmd + = DropAbsent + + | isStrUsedDmd dmd + , Just (tc, tc_args, co) <- normSplitTyConApp_maybe fam_envs ty + , Just dc <- tyConSingleAlgDataCon_maybe tc + , let arity = dataConRepArity dc + -- See Note [Unpacking arguments with product and polymorphic demands] + , Just cs <- split_prod_dmd_arity dmd arity + -- See Note [Do not unpack class dictionaries] + , inlineable_flag == NotArgOfInlineableFun || not (isClassPred ty) + -- See Note [mkWWstr and unsafeCoerce] + , cs `lengthIs` arity + -- See Note [Add demands for strict constructors] + , let cs' = addDataConStrictness dc cs + = Unbox (DataConPatContext dc tc_args co) cs' + + | otherwise + = StopUnboxing + where split_prod_dmd_arity dmd arity -- For seqDmd, it should behave like <S(AAAA)>, for some @@ -629,6 +623,55 @@ wantToUnbox fam_envs has_inlineable_prag ty dmd = | _ :* Prod ds <- dmd = Just ds | otherwise = Nothing +addDataConStrictness :: DataCon -> [Demand] -> [Demand] +-- See Note [Add demands for strict constructors] +addDataConStrictness con ds + | Nothing <- dataConWrapId_maybe con + -- DataCon worker=wrapper. Implies no strict fields, so nothing to do + = ds +addDataConStrictness con ds + = zipWithEqual "addDataConStrictness" add ds strs + where + strs = dataConRepStrictness con + add dmd str | isMarkedStrict str = strictifyDmd dmd + | otherwise = dmd + + +-- | Unboxing strategy for constructed results. +wantToUnboxResult :: FamInstEnvs -> Type -> Cpr -> UnboxingDecision Cpr +-- See Note [Which types are unboxed?] +wantToUnboxResult fam_envs ty cpr + | Just (con_tag, _cprs) <- asConCpr cpr + , Just (tc, tc_args, co) <- normSplitTyConApp_maybe fam_envs ty + , isDataTyCon tc -- NB: No unboxed sums or tuples + , Just dcs <- tyConAlgDataCons_maybe tc <|> open_body_ty_warning + , dcs `lengthAtLeast` con_tag -- This might not be true if we import the + -- type constructor via a .hs-boot file (#8743) + , let dc = dcs `getNth` (con_tag - fIRST_TAG) + , null (dataConExTyCoVars dc) -- no existentials; + -- See Note [Which types are unboxed?] + -- and GHC.Core.Opt.CprAnal.argCprType + -- where we also check this. + , all isLinear (dataConInstArgTys dc tc_args) + -- Deactivates CPR worker/wrapper splits on constructors with non-linear + -- arguments, for the moment, because they require unboxed tuple with variable + -- multiplicity fields. + = Unbox (DataConPatContext dc tc_args co) [] + + | otherwise + = StopUnboxing + + where + -- | See Note [non-algebraic or open body type warning] + open_body_ty_warning = WARN( True, text "wantToUnboxResult: non-algebraic or open body type" <+> ppr ty ) Nothing + +isLinear :: Scaled a -> Bool +isLinear (Scaled w _ ) = + case w of + One -> True + _ -> False + + {- Note [Which types are unboxed?] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Worker/wrapper will unbox @@ -659,8 +702,8 @@ Worker/wrapper will unbox to > $wf x y = let ... in (# @ex, (a :: ..ex..), (b :: ..ex..) #) -The respective tests are in 'splitArgType_maybe' and -'splitResultType_maybe', respectively. +The respective tests are in 'wantToUnboxArg' and +'wantToUnboxResult', respectively. Note that the data constructor /can/ have evidence arguments: equality constraints, type classes etc. So it can be GADT. These evidence @@ -699,7 +742,7 @@ If we have f :: Ord a => [a] -> Int -> a {-# INLINABLE f #-} and we worker/wrapper f, we'll get a worker with an INLINABLE pragma -(see Note [Worker-wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap), +(see Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap), which can still be specialised by the type-class specialiser, something like fw :: Ord a => [a] -> Int# -> a @@ -765,7 +808,7 @@ So here's what we do * What does "bump up the strictness" mean? Just add a head-strict demand to the strictness! Even for a demand like <L,A> we can safely turn it into <S,A>; remember case (1) of - Note [How to do the worker/wrapper split]. + Note [Worker/wrapper for Strictness and Absence]. The net effect is that the w/w transformation is more aggressive about unpacking the strict arguments of a data constructor, when that @@ -840,35 +883,54 @@ Consequently, we now instead account for data-con strictness in mkWWstr_one, applying the strictness demands to the final result of DmdAnal. The result is that we get the strict demand signature we wanted even if we can't float the case on `x` up through the case on `burble`. + +Note [non-algebraic or open body type warning] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are a few cases where the W/W transformation is told that something +returns a constructor, but the type at hand doesn't really match this. One +real-world example involves unsafeCoerce: + foo = IO a + foo = unsafeCoerce c_exit + foreign import ccall "c_exit" c_exit :: IO () +Here CPR will tell you that `foo` returns a () constructor for sure, but trying +to create a worker/wrapper for type `a` obviously fails. +(This was a real example until ee8e792 in libraries/base.) + +It does not seem feasible to avoid all such cases already in the analyser (and +after all, the analysis is not really wrong), so we simply do nothing here in +mkWWcpr. But we still want to emit warning with -DDEBUG, to hopefully catch +other cases where something went avoidably wrong. + +This warning also triggers for the stream fusion library within `text`. +We can'easily W/W constructed results like `Stream` because we have no simple +way to express existential types in the worker's type signature. -} {- ************************************************************************ * * -\subsection{Strictness stuff} +\subsection{Worker/wrapper for Strictness and Absence} * * ************************************************************************ -} -mkWWstr :: DynFlags - -> FamInstEnvs - -> Bool -- True <=> INLINEABLE pragma on this function defn - -- See Note [Do not unpack class dictionaries] - -> [Var] -- Wrapper args; have their demand info on them - -- *Includes type variables* - -> UniqSM (Bool, -- Is this useful - [Var], -- Worker args - CoreExpr -> CoreExpr, -- Wrapper body, lacking the worker call - -- and without its lambdas - -- This fn adds the unboxing - - CoreExpr -> CoreExpr) -- Worker body, lacking the original body of the function, - -- and lacking its lambdas. - -- This fn does the reboxing -mkWWstr dflags fam_envs has_inlineable_prag args +mkWWstr :: WwOpts + -> ArgOfInlineableFun -- See Note [Do not unpack class dictionaries] + -> [Var] -- Wrapper args; have their demand info on them + -- *Includes type variables* + -> UniqSM (Bool, -- Is this useful + [Var], -- Worker args + CoreExpr -> CoreExpr, -- Wrapper body, lacking the worker call + -- and without its lambdas + -- This fn adds the unboxing + + CoreExpr -> CoreExpr) -- Worker body, lacking the original body of the function, + -- and lacking its lambdas. + -- This fn does the reboxing +mkWWstr opts inlineable_flag args = go args where - go_one arg = mkWWstr_one dflags fam_envs has_inlineable_prag arg + go_one arg = mkWWstr_one opts inlineable_flag arg go [] = return (False, [], nop_fn, nop_fn) go (arg : args) = do { (useful1, args1, wrap_fn1, work_fn1) <- go_one arg @@ -884,76 +946,104 @@ mkWWstr dflags fam_envs has_inlineable_prag args -- brings into scope work_args (via cases) -- * work_fn assumes work_args are in scope, a -- brings into scope wrap_arg (via lets) --- See Note [How to do the worker/wrapper split] -mkWWstr_one :: DynFlags -> FamInstEnvs - -> Bool -- True <=> INLINEABLE pragma on this function defn - -- See Note [Do not unpack class dictionaries] +-- See Note [Worker/wrapper for Strictness and Absence] +mkWWstr_one :: WwOpts + -> ArgOfInlineableFun -- See Note [Do not unpack class dictionaries] -> Var -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) -mkWWstr_one dflags fam_envs has_inlineable_prag arg - | isTyVar arg - = return (False, [arg], nop_fn, nop_fn) +mkWWstr_one opts inlineable_flag arg = + case wantToUnboxArg fam_envs inlineable_flag arg_ty arg_dmd of + _ | isTyVar arg -> do_nothing - | isAbsDmd dmd - , Just work_fn <- mk_absent_let dflags arg dmd - -- Absent case. We can't always handle absence for rep-polymorphic - -- types, so we need to choose just the cases we can - -- (that's what mk_absent_let does) - = return (True, [], nop_fn, work_fn) + DropAbsent + | Just work_fn <- mk_absent_let opts arg + -- Absent case. We can't always handle absence for arbitrary + -- unlifted types, so we need to choose just the cases we can + -- (that's what mk_absent_let does) + -> return (True, [], nop_fn, work_fn) - | Unbox dcpc cs <- wantToUnbox fam_envs has_inlineable_prag arg_ty dmd - = unbox_one dflags fam_envs arg cs dcpc + Unbox dcpc cs -> unbox_one_arg opts arg cs dcpc - | otherwise -- Other cases - = return (False, [arg], nop_fn, nop_fn) + _ -> do_nothing -- Other cases, like StopUnboxing where - arg_ty = idType arg - dmd = idDemandInfo arg + fam_envs = wo_fam_envs opts + arg_ty = idType arg + arg_dmd = idDemandInfo arg + do_nothing = return (False, [arg], nop_fn, nop_fn) -unbox_one :: DynFlags -> FamInstEnvs -> Var +unbox_one_arg :: WwOpts + -> Var -> [Demand] -> DataConPatContext -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) -unbox_one dflags fam_envs arg cs +unbox_one_arg opts arg cs DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args , dcpc_co = co } - = do { (case_bndr_uniq:pat_bndrs_uniqs) <- getUniquesM + = do { pat_bndrs_uniqs <- getUniquesM ; let ex_name_fss = map getOccFS $ dataConExTyCoVars dc (ex_tvs', arg_ids) = dataConRepFSInstPat (ex_name_fss ++ repeat ww_prefix) pat_bndrs_uniqs (idMult arg) dc tc_args - arg_ids' = zipWithEqual "unbox_one" setIdDemandInfo arg_ids cs - unbox_fn = mkUnpackCase (Var arg) co (idMult arg) case_bndr_uniq + arg_ids' = zipWithEqual "unbox_one_arg" setIdDemandInfo arg_ids cs + unbox_fn = mkUnpackCase (Var arg) co (idMult arg) dc (ex_tvs' ++ arg_ids') arg_no_unf = zapStableUnfolding arg -- See Note [Zap unfolding when beta-reducing] -- in GHC.Core.Opt.Simplify; and see #13890 rebox_fn = Let (NonRec arg_no_unf con_app) con_app = mkConApp2 dc tc_args (ex_tvs' ++ arg_ids') `mkCast` mkSymCo co - ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False (ex_tvs' ++ arg_ids') + ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr opts NotArgOfInlineableFun (ex_tvs' ++ arg_ids') ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) } -- Don't pass the arg, rebox instead ----------------------- -nop_fn :: CoreExpr -> CoreExpr -nop_fn body = body +-- | Tries to find a suitable dummy RHS to bind the given absent identifier to. +-- +-- If @mk_absent_let _ id == Just wrap@, then @wrap e@ will wrap a let binding +-- for @id@ with that RHS around @e@. Otherwise, there could no suitable RHS be +-- found. +mk_absent_let :: WwOpts -> Id -> Maybe (CoreExpr -> CoreExpr) +mk_absent_let opts arg + -- The lifted case: Bind 'absentError' for a nice panic message if we are + -- wrong (like we were in #11126). See (1) in Note [Absent fillers] + | Just [LiftedRep] <- mb_mono_prim_reps + , not (isStrictDmd (idDemandInfo arg)) -- See (2) in Note [Absent fillers] + = Just (Let (NonRec arg panic_rhs)) -addDataConStrictness :: DataCon -> [Demand] -> [Demand] --- See Note [Add demands for strict constructors] -addDataConStrictness con ds - | Nothing <- dataConWrapId_maybe con - -- DataCon worker=wrapper. Implies no strict fields, so nothing to do - = ds -addDataConStrictness con ds - = zipWithEqual "addDataConStrictness" add ds strs + -- The default case for mono rep: Bind @RUBBISH[prim_reps] \@arg_ty@ + -- See Note [Absent fillers], the main part + | Just prim_reps <- mb_mono_prim_reps + = Just (bindNonRec arg (mkTyApps (Lit (mkLitRubbish prim_reps)) [arg_ty])) + + -- Catch all: Either @arg_ty@ wasn't of form @TYPE rep@ or @rep@ wasn't mono rep. + -- See (3) in Note [Absent fillers] + | Nothing <- mb_mono_prim_reps + = WARN( True, text "No absent value for" <+> ppr arg_ty ) + Nothing where - strs = dataConRepStrictness con - add dmd str | isMarkedStrict str = strictifyDmd dmd - | otherwise = dmd + arg_ty = idType arg + mb_mono_prim_reps = typeMonoPrimRep_maybe arg_ty + + panic_rhs = mkAbsentErrorApp arg_ty msg -{- Note [How to do the worker/wrapper split] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The worker-wrapper transformation, mkWWstr_one, takes into account + msg = renderWithContext + (defaultSDocContext { sdocSuppressUniques = True }) + (vcat + [ text "Arg:" <+> ppr arg + , text "Type:" <+> ppr arg_ty + , file_msg ]) + -- We need to suppress uniques here because otherwise they'd + -- end up in the generated code as strings. This is bad for + -- determinism, because with different uniques the strings + -- will have different lengths and hence different costs for + -- the inliner leading to different inlining. + -- See also Note [Unique Determinism] in GHC.Types.Unique + file_msg = case wo_output_file opts of + Nothing -> empty + Just f -> text "In output file " <+> quotes (text f) + +{- Note [Worker/wrapper for Strictness and Absence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The worker/wrapper transformation, mkWWstr_one, takes into account several possibilities to decide if the function is worthy for splitting: @@ -1004,7 +1094,7 @@ splitting: like U(AAAA) for suitable number of absent demands. So we have a special case for it, with arity coming from the data constructor. -Note [Worker-wrapper for bottoming functions] +Note [Worker/wrapper for bottoming functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We used not to split if the result is bottom. [Justification: there's no efficiency to be gained.] @@ -1052,13 +1142,98 @@ Missing these facts isn't unsound, but it loses possible future opportunities for optimisation. Solution: use setCaseBndrEvald when creating - (A) The arg binders x1,x2 in mkWstr_one + (A) The arg binders x1,x2 in mkWstr_one via mkUnpackCase See #13077, test T13077 - (B) The result binders r1,r2 in mkWWcpr_help + (B) The result binders r1,r2 in mkWWcpr_entry See Trace #13077, test T13077a And #13027 comment:20, item (4) to record that the relevant binder is evaluated. +Note [Absent fillers] +~~~~~~~~~~~~~~~~~~~~~ +Consider + + data T = MkT [Int] [Int] ![Int] -- NB: last field is strict + f :: T -> Int# -> blah + f ps w = case ps of MkT xs ys zs -> <body mentioning xs> + +Then f gets a strictness sig of <S(L,A,A)><A>. We make a worker $wf thus: + + $wf :: [Int] -> blah + $wf xs = case ps of MkT xs _ _ -> <body mentioning xs> + where + ys = absentError "ys :: [Int]" + zs = RUBBISH[LiftedRep] @[Int] + ps = MkT xs ys zs + w = RUBBISH[IntRep] @Int# + +The absent arguments 'ys', 'zs' and 'w' aren't even passed to the worker. +And neither should they! They are never used, their value is irrelevant (hence +they are *dead code*) and they are probably discarded after the next run of the +Simplifier (when they are in fact *unreachable code*). Yet, we have to come up +with "filler" values that we bind the absent arg Ids to. + +That is exactly what Note [Rubbish values] are for: A convenient way to +conjure filler values at any type (and any representation or levity!). + +Needless to say, there are some wrinkles: + + 1. In case we have a absent, /lazy/, and /lifted/ arg, we use an error-thunk + instead. If absence analysis was wrong (e.g., #11126) and the binding + in fact is used, then we get a nice panic message instead of undefined + runtime behavior (See Modes of failure from Note [Rubbish values]). + + Obviously, we can't use an error-thunk if the value is of unlifted rep + (like 'Int#' or 'MutVar#'), because we'd immediately evaluate the panic. + + 2. We also mustn't put an error-thunk (that fills in for an absent value of + lifted rep) in a strict field, because #16970 establishes the invariant + that strict fields are always evaluated, by (re-)evaluating what is put in + a strict field. That's the reason why 'zs' binds a rubbish literal instead + of an error-thunk, see #19133. + + How do we detect when we are about to put an error-thunk in a strict field? + Ideally, we'd just look at the 'StrictnessMark' of the DataCon's field, but + it's quite nasty to thread the marks though 'mkWWstr' and 'mkWWstr_one'. + So we rather look out for a necessary condition for strict fields: + Note [Add demands for strict constructors] makes it so that the demand on + 'zs' is absent and /strict/: It will get cardinality 'C_10', the empty + interval, rather than 'C_00'. Hence the 'isStrictDmd' check: It guarantees + we never fill in an error-thunk for an absent strict field. + But that also means we emit a rubbish lit for other args that have + cardinality 'C_10' (say, the arg to a bottoming function) where we could've + used an error-thunk, but that's a small price to pay for simplicity. + + 3. We can only emit a RubbishLit if the arg's type @arg_ty@ is mono-rep, e.g. + of the form @TYPE rep@ where @rep@ is not (and doesn't contain) a variable. + Why? Because if we don't know its representation (e.g. size in memory, + register class), we don't know what or how much rubbish to emit in codegen. + 'typeMonoPrimRep_maybe' returns 'Nothing' in this case and we simply fall + back to passing the original parameter to the worker. + + Note that currently this case should not occur, because binders always + have to be representation monomorphic. But in the future, we might allow + levity polymorphism, e.g. a polymorphic levity variable in 'BoxedRep'. + +While (1) and (2) are simply an optimisation in terms of compiler debugging +experience, (3) should be irrelevant in most programs, if not all. + +Historical note: I did try the experiment of using an error thunk for unlifted +things too, relying on the simplifier to drop it as dead code. But this is +fragile + + - It fails when profiling is on, which disables various optimisations + + - It fails when reboxing happens. E.g. + data T = MkT Int Int# + f p@(MkT a _) = ...g p.... + where g is /lazy/ in 'p', but only uses the first component. Then + 'f' is /strict/ in 'p', and only uses the first component. So we only + pass that component to the worker for 'f', which reconstructs 'p' to + pass it to 'g'. Alas we can't say + ...f (MkT a (absentError Int# "blah"))... + because `MkT` is strict in its Int# argument, so we get an absentError + exception when we shouldn't. Very annoying! ************************************************************************ * * @@ -1128,136 +1303,289 @@ dubiousDataConInstArgTys dc tc_args = arg_tys {- ************************************************************************ * * -\subsection{CPR stuff} +\subsection{Worker/wrapper for CPR} * * ************************************************************************ +See Note [Worker/wrapper for CPR] for an overview. +-} +mkWWcpr_entry + :: WwOpts + -> Type -- function body + -> Cpr -- CPR analysis results + -> UniqSM (Bool, -- Is w/w'ing useful? + CoreExpr -> CoreExpr, -- New wrapper. 'nop_fn' if not useful + CoreExpr -> CoreExpr, -- New worker. 'nop_fn' if not useful + Type) -- Type of worker's body. + -- Just the input body_ty if not useful +-- ^ Entrypoint to CPR W/W. See Note [Worker/wrapper for CPR] for an overview. +mkWWcpr_entry opts body_ty body_cpr + | not (wo_cpr_anal opts) = return (False, nop_fn, nop_fn, body_ty) + | otherwise = do + -- Part (1) + res_bndr <- mk_res_bndr body_ty + let bind_res_bndr body scope = mkDefaultCase body res_bndr scope + deref_res_bndr = Var res_bndr + + -- Part (2) + (useful, fromOL -> transit_vars, wrap_build_res, work_unpack_res) <- + mkWWcpr_one opts res_bndr body_cpr + + -- Part (3) + let (unbox_transit_tup, transit_tup) = move_transit_vars transit_vars + + -- Stacking unboxer (work_fn) and builder (wrap_fn) together + let wrap_fn = unbox_transit_tup (wrap_build_res deref_res_bndr) -- 3 2 1 + work_fn body = bind_res_bndr body (work_unpack_res transit_tup) -- 1 2 3 + work_body_ty = exprType transit_tup + return $ if not useful + then (False, nop_fn, nop_fn, body_ty) + else (True, wrap_fn, work_fn, work_body_ty) + +-- | Part (1) of Note [Worker/wrapper for CPR]. +mk_res_bndr :: Type -> UniqSM Id +mk_res_bndr body_ty = do + -- See Note [Linear types and CPR] + bndr <- mkSysLocalOrCoVarM ww_prefix cprCaseBndrMult body_ty + -- See Note [Record evaluated-ness in worker/wrapper] + pure (setCaseBndrEvald MarkedStrict bndr) + +-- | What part (2) of Note [Worker/wrapper for CPR] collects. +-- +-- 1. A Bool capturing whether the transformation did anything useful. +-- 2. The list of transit variables (see the Note). +-- 3. The result builder expression for the wrapper. 'nop_fn' if not useful. +-- 4. The result unpacking expression for the worker. 'nop_fn' if not useful. +type CprWwResult = (Bool, OrdList Var, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) + +mkWWcpr :: WwOpts -> [Id] -> [Cpr] -> UniqSM CprWwResult +mkWWcpr _opts vars [] = + -- special case: No CPRs means all top (for example from FlatConCpr), + -- hence stop WW. + return (False, toOL vars, nop_fn, nop_fn) +mkWWcpr opts vars cprs = do + -- No existentials in 'vars'. 'wantToUnboxResult' should have checked that. + MASSERT2( not (any isTyVar vars), ppr vars $$ ppr cprs ) + MASSERT2( equalLength vars cprs, ppr vars $$ ppr cprs ) + (usefuls, varss, wrap_build_ress, work_unpack_ress) <- + unzip4 <$> zipWithM (mkWWcpr_one opts) vars cprs + return ( or usefuls + , concatOL varss + , foldl' (.) nop_fn wrap_build_ress + , foldl' (.) nop_fn work_unpack_ress ) + +mkWWcpr_one :: WwOpts -> Id -> Cpr -> UniqSM CprWwResult +-- ^ See if we want to unbox the result and hand off to 'unbox_one_result'. +mkWWcpr_one opts res_bndr cpr + | ASSERT( not (isTyVar res_bndr) ) True + , Unbox dcpc arg_cprs <- wantToUnboxResult (wo_fam_envs opts) (idType res_bndr) cpr + = unbox_one_result opts res_bndr arg_cprs dcpc + | otherwise + = return (False, unitOL res_bndr, nop_fn, nop_fn) + +unbox_one_result + :: WwOpts -> Id -> [Cpr] -> DataConPatContext -> UniqSM CprWwResult +-- ^ Implements the main bits of part (2) of Note [Worker/wrapper for CPR] +unbox_one_result opts res_bndr arg_cprs + DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args + , dcpc_co = co } = do + -- unboxer (free in `res_bndr`): | builder (binds `res_bndr`): + -- ( case res_bndr of (i, j) -> ) | ( let j = I# b in ) + -- ( case i of I# a -> ) | ( let i = I# a in ) + -- ( case j of I# b -> ) | ( let res_bndr = (i, j) in ) + -- ( <hole> ) | ( <hole> ) + pat_bndrs_uniqs <- getUniquesM + let (_exs, arg_ids) = + dataConRepFSInstPat (repeat ww_prefix) pat_bndrs_uniqs cprCaseBndrMult dc tc_args + MASSERT( null _exs ) -- Should have been caught by wantToUnboxResult + + let -- con_app = (C a b |> sym co) + con_app = mkConApp2 dc tc_args arg_ids `mkCast` mkSymCo co + -- this_wrap_build_res body = (let res_bndr = C a b |> sym co in <body>[r]) + this_wrap_build_res = Let (NonRec res_bndr con_app) + -- this_work_unbox_res alt = (case res_bndr |> co of C a b -> <alt>[a,b]) + this_work_unbox_res = mkUnpackCase (Var res_bndr) co cprCaseBndrMult dc arg_ids + + (nested_useful, transit_vars, wrap_build_res, work_unbox_res) <- + mkWWcpr opts arg_ids arg_cprs + + -- Don't try to WW an unboxed tuple return type when there's nothing inside + -- to unbox further. + return $ if isUnboxedTupleDataCon dc && not nested_useful + then ( False, unitOL res_bndr, nop_fn, nop_fn ) + else ( True + , transit_vars + , wrap_build_res . this_wrap_build_res + , this_work_unbox_res . work_unbox_res + ) + +-- | Implements part (3) of Note [Worker/wrapper for CPR]. +-- +-- If `move_transit_vars [a,b] = (unbox, tup)` then +-- * `a` and `b` are the *transit vars* to be returned from the worker +-- to the wrapper +-- * `unbox scrut alt = (case <scrut> of (# a, b #) -> <alt>)` +-- * `tup = (# a, b #)` +-- There is a special case for when there's 1 transit var, +-- see Note [No unboxed tuple for single, unlifted transit var]. +move_transit_vars :: [Id] -> (CoreExpr -> CoreExpr -> CoreExpr, CoreExpr) +move_transit_vars vars + | [var] <- vars + , let var_ty = idType var + , isUnliftedType var_ty || exprIsHNF (Var var) + -- See Note [No unboxed tuple for single, unlifted transit var] + -- * Wrapper: `unbox scrut alt = (case <scrut> of a -> <alt>)` + -- * Worker: `tup = a` + = ( \build_res wkr_call -> mkDefaultCase wkr_call var build_res + , varToCoreExpr var ) -- varToCoreExpr important here: var can be a coercion + -- Lacking this caused #10658 + | otherwise + -- The general case: Just return an unboxed tuple from the worker + -- * Wrapper: `unbox scrut alt = (case <scrut> of (# a, b #) -> <alt>)` + -- * Worker: `tup = (# a, b #)` + = ( \build_res wkr_call -> mkSingleAltCase wkr_call case_bndr + (DataAlt tup_con) vars build_res + , ubx_tup_app ) + where + ubx_tup_app = mkCoreUbxTup (map idType vars) (map varToCoreExpr vars) + tup_con = tupleDataCon Unboxed (length vars) + -- See also Note [Linear types and CPR] + case_bndr = mkWildValBinder cprCaseBndrMult (exprType ubx_tup_app) + + +{- Note [Worker/wrapper for CPR] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'mkWWcpr_entry' is the entry-point to the worker/wrapper transformation that +exploits CPR info. Here's an example: +``` + f :: ... -> (Int, Int) + f ... = <body> +``` +Let's assume the CPR info `body_cpr` for the body of `f` says +"unbox the pair and its components" and `body_ty` is the type of the function +body `body` (i.e., `(Int, Int)`). Then `mkWWcpr_entry body_ty body_cpr` returns + + * A result-unpacking expression for the worker, with a hole for the fun body: + ``` + unpack body = ( case <body> of r __DEFAULT -> ) -- (1) + ( case r of (i, j) -> ) -- (2) + ( case i of I# a -> ) -- (2) + ( case j of I# b -> ) -- (2) + ( (# a, b #) ) -- (3) + ``` + * A result-building expression for the wrapper, with a hole for the worker call: + ``` + build wkr_call = ( case <wkr_call> of (# a, b #) -> ) -- (3) + ( let j = I# b in ) -- (2) + ( let i = I# a in ) -- (2) + ( let r = (i, j) in ) -- (2) + ( r ) -- (1) + ``` + * The result type of the worker, e.g., `(# Int#, Int# #)` above. + +To achieve said transformation, 'mkWWcpr_entry' + + 1. First allocates a fresh result binder `r`, giving a name to the `body` + expression and contributing part (1) of the unpacker and builder. + 2. Then it delegates to 'mkWWcpr_one', which recurses into all result fields + to unbox, contributing the parts marked with (2). Crucially, it knows + what belongs in the case scrutinee of the unpacker through the communicated + Id `r`: The unpacking expression will be free in that variable. + (This is a similar contract as that of 'mkWWstr_one' for strict args.) + 3. 'mkWWstr_one' produces a bunch of *transit vars*: Those result variables + that have to be transferred from the worker to the wrapper, where the + constructed result can be rebuilt, `a` and `b` above. Part (3) is + responsible for tupling them up in the worker and taking the tuple apart + in the wrapper. This is implemented in 'move_transit_vars'. + +Note [No unboxed tuple for single, unlifted transit var] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When there's only a single, unlifted transit var (Note [Worker/wrapper for CPR]), +we don't wrap an unboxed singleton tuple around it (which otherwise would be +needed to suspend evaluation) and return the unlifted thing directly. E.g. +``` + f :: Int -> Int + f x = x+1 +``` +We certainly want `$wf :: Int# -> Int#`, not `$wf :: Int# -> (# Int# #)`. +This is OK as long as we know that evaluation of the returned thing terminates +quickly, as is the case for fields of unlifted type like `Int#`. + +But more generally, this should also be true for *lifted* types that terminate +quickly! Consider from `T18109`: +``` + data F = F (Int -> Int) + f :: Int -> F + f n = F (+n) + + data T = T (Int, Int) + g :: T -> T + g t@(T p) = p `seq` t + + data U = U ![Int] + h :: Int -> U + h n = U [0..n] +``` +All of the nested fields are actually ok-for-speculation and thus OK to +return unboxed instead of in an unboxed singleton tuple: + + 1. The field of `F` is a HNF. + We want `$wf :: Int -> Int -> Int`. + We get `$wf :: Int -> (# Int -> Int #)`. + 2. The field of `T` is `seq`'d in `g`. + We want `$wg :: (Int, Int) -> (Int, Int)`. + We get `$wg :: (Int, Int) -> (# (Int, Int) #)`. + 3. The field of `U` is strict and thus always evaluated. + We want `$wh :: Int# -> [Int]`. + We'd get `$wh :: Int# -> (# [Int] #)`. + +By considering vars as unlifted that satsify 'exprIsHNF', we catch (3). +Why not check for 'exprOkForSpeculation'? Quite perplexingly, evaluated vars +are not ok-for-spec, see Note [exprOkForSpeculation and evaluated variables]. +For (1) and (2) we would have to look at the term. WW only looks at the +type and the CPR signature, so the only way to fix (1) and (2) would be to +have a nested termination signature, like in MR !1866. + +Note [Linear types and CPR] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Remark on linearity: in both the case of the wrapper and the worker, +we build a linear case to unpack constructed products. All the +multiplicity information is kept in the constructors (both C and (#, #)). +In particular (#,#) is parametrised by the multiplicity of its fields. +Specifically, in this instance, the multiplicity of the fields of (#,#) +is chosen to be the same as those of C. -@mkWWcpr@ takes the worker/wrapper pair produced from the strictness -info and adds in the CPR transformation. The worker returns an -unboxed tuple containing non-CPR components. The wrapper takes this -tuple and re-produces the correct structured output. -The non-CPR results appear ordered in the unboxed tuple as if by a -left-to-right traversal of the result structure. +************************************************************************ +* * +\subsection{Utilities} +* * +************************************************************************ -} -mkWWcpr :: Bool - -> FamInstEnvs - -> Type -- function body type - -> Cpr -- CPR analysis results - -> UniqSM (Bool, -- Is w/w'ing useful? - CoreExpr -> CoreExpr, -- New wrapper - CoreExpr -> CoreExpr, -- New worker - Type) -- Type of worker's body - -mkWWcpr opt_CprAnal fam_envs body_ty cpr - -- CPR explicitly turned off (or in -O0) - | not opt_CprAnal = return (False, id, id, body_ty) - -- CPR is turned on by default for -O and O2 - | otherwise - = case asConCpr cpr of - Nothing -> return (False, id, id, body_ty) -- No CPR info - Just (con_tag, _cprs) - | Just dcpc <- splitResultType_maybe fam_envs con_tag body_ty - -> mkWWcpr_help dcpc - | otherwise - -- See Note [non-algebraic or open body type warning] - -> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty ) - return (False, id, id, body_ty) - -mkWWcpr_help :: DataConPatContext - -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type) - -mkWWcpr_help (DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args - , dcpc_co = co }) - | [arg_ty] <- dataConInstArgTys dc tc_args -- NB: No existentials! - , [str_mark] <- dataConRepStrictness dc - , isUnliftedType (scaledThing arg_ty) - , isLinear arg_ty - -- Special case when there is a single result of unlifted, linear, type - -- - -- Wrapper: case (..call worker..) of x -> C x - -- Worker: case ( ..body.. ) of C x -> x - = do { (work_uniq : arg_uniq : _) <- getUniquesM - ; let arg_id = mk_ww_local arg_uniq str_mark arg_ty - con_app = mkConApp2 dc tc_args [arg_id] `mkCast` mkSymCo co - - ; return ( True - , \ wkr_call -> mkDefaultCase wkr_call arg_id con_app - , \ body -> mkUnpackCase body co One work_uniq dc [arg_id] (varToCoreExpr arg_id) - -- varToCoreExpr important here: arg can be a coercion - -- Lacking this caused #10658 - , scaledThing arg_ty ) } - - | otherwise -- The general case - -- Wrapper: case (..call worker..) of (# a, b #) -> C a b - -- Worker: case ( ...body... ) of C a b -> (# a, b #) - -- - -- Remark on linearity: in both the case of the wrapper and the worker, - -- we build a linear case. All the multiplicity information is kept in - -- the constructors (both C and (#, #)). In particular (#,#) is - -- parametrised by the multiplicity of its fields. Specifically, in this - -- instance, the multiplicity of the fields of (#,#) is chosen to be the - -- same as those of C. - = do { (work_uniq : wild_uniq : pat_bndrs_uniqs) <- getUniquesM - ; let case_mult = One -- see above - (_exs, arg_ids) = - dataConRepFSInstPat (repeat ww_prefix) pat_bndrs_uniqs case_mult dc tc_args - wrap_wild = mk_ww_local wild_uniq MarkedStrict (Scaled case_mult ubx_tup_ty) - ubx_tup_ty = exprType ubx_tup_app - ubx_tup_app = mkCoreUbxTup (map idType arg_ids) (map varToCoreExpr arg_ids) - con_app = mkConApp2 dc tc_args arg_ids `mkCast` mkSymCo co - tup_con = tupleDataCon Unboxed (length arg_ids) - - ; MASSERT( null _exs ) -- Should have been caught by splitResultType_maybe - - ; return (True - , \ wkr_call -> mkSingleAltCase wkr_call wrap_wild - (DataAlt tup_con) arg_ids con_app - , \ body -> mkUnpackCase body co case_mult work_uniq dc arg_ids ubx_tup_app - , ubx_tup_ty ) } - -mkUnpackCase :: CoreExpr -> Coercion -> Mult -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr --- (mkUnpackCase e co uniq Con args body) +mkUnpackCase :: CoreExpr -> Coercion -> Mult -> DataCon -> [Id] -> CoreExpr -> CoreExpr +-- (mkUnpackCase e co Con args body) -- returns --- case e |> co of bndr { Con args -> body } - -mkUnpackCase (Tick tickish e) co mult uniq con args body -- See Note [Profiling and unpacking] - = Tick tickish (mkUnpackCase e co mult uniq con args body) -mkUnpackCase scrut co mult uniq boxing_con unpk_args body +-- case e |> co of _dead { Con args -> body } +mkUnpackCase (Tick tickish e) co mult con args body -- See Note [Profiling and unpacking] + = Tick tickish (mkUnpackCase e co mult con args body) +mkUnpackCase scrut co mult boxing_con unpk_args body = mkSingleAltCase casted_scrut bndr (DataAlt boxing_con) unpk_args body where casted_scrut = scrut `mkCast` co - bndr = mk_ww_local uniq MarkedStrict (Scaled mult (exprType casted_scrut)) - -- An unpacking case can always be chosen linear, because the variables - -- are always passed to a constructor. This limits the -{- -Note [non-algebraic or open body type warning] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -There are a few cases where the W/W transformation is told that something -returns a constructor, but the type at hand doesn't really match this. One -real-world example involves unsafeCoerce: - foo = IO a - foo = unsafeCoerce c_exit - foreign import ccall "c_exit" c_exit :: IO () -Here CPR will tell you that `foo` returns a () constructor for sure, but trying -to create a worker/wrapper for type `a` obviously fails. -(This was a real example until ee8e792 in libraries/base.) + bndr = mkWildValBinder mult (exprType casted_scrut) -It does not seem feasible to avoid all such cases already in the analyser (and -after all, the analysis is not really wrong), so we simply do nothing here in -mkWWcpr. But we still want to emit warning with -DDEBUG, to hopefully catch -other cases where something went avoidably wrong. +-- | The multiplicity of a case binder unboxing a constructed result. +-- See Note [Linear types and CPR] +cprCaseBndrMult :: Mult +cprCaseBndrMult = One -This warning also triggers for the stream fusion library within `text`. -We can'easily W/W constructed results like `Stream` because we have no simple -way to express existential types in the worker's type signature. +ww_prefix :: FastString +ww_prefix = fsLit "ww" -Note [Profiling and unpacking] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Profiling and unpacking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If the original function looked like f = \ x -> {-# SCC "foo" #-} E @@ -1273,153 +1601,4 @@ Later [SDM]: presumably this is because we want the simplifier to eliminate the case, and the scc would get in the way? I'm ok with including the case itself in the cost centre, since it is morally part of the function (post transformation) anyway. - - -************************************************************************ -* * -\subsection{Utilities} -* * -************************************************************************ - -Note [Absent fillers] -~~~~~~~~~~~~~~~~~~~~~ -Consider - - data T = MkT [Int] [Int] ![Int] -- NB: last field is strict - f :: T -> Int# -> blah - f ps w = case ps of MkT xs ys zs -> <body mentioning xs> - -Then f gets a strictness sig of <S(L,A,A)><A>. We make a worker $wf thus: - - $wf :: [Int] -> blah - $wf xs = case ps of MkT xs _ _ -> <body mentioning xs> - where - ys = absentError "ys :: [Int]" - zs = RUBBISH[LiftedRep] @[Int] - ps = MkT xs ys zs - w = RUBBISH[IntRep] @Int# - -The absent arguments 'ys', 'zs' and 'w' aren't even passed to the worker. -And neither should they! They are never used, their value is irrelevant (hence -they are *dead code*) and they are probably discarded after the next run of the -Simplifier (when they are in fact *unreachable code*). Yet, we have to come up -with "filler" values that we bind the absent arg Ids to. - -That is exactly what Note [Rubbish values] are for: A convenient way to -conjure filler values at any type (and any representation or levity!). - -Needless to say, there are some wrinkles: - - 1. In case we have a absent, /lazy/, and /lifted/ arg, we use an error-thunk - instead. If absence analysis was wrong (e.g., #11126) and the binding - in fact is used, then we get a nice panic message instead of undefined - runtime behavior (See Modes of failure from Note [Rubbish values]). - - Obviously, we can't use an error-thunk if the value is of unlifted rep - (like 'Int#' or 'MutVar#'), because we'd immediately evaluate the panic. - - 2. We also mustn't put an error-thunk (that fills in for an absent value of - lifted rep) in a strict field, because #16970 establishes the invariant - that strict fields are always evaluated, by (re-)evaluating what is put in - a strict field. That's the reason why 'zs' binds a rubbish literal instead - of an error-thunk, see #19133. - - How do we detect when we are about to put an error-thunk in a strict field? - Ideally, we'd just look at the 'StrictnessMark' of the DataCon's field, but - it's quite nasty to thread the marks though 'mkWWstr' and 'mkWWstr_one'. - So we rather look out for a necessary condition for strict fields: - Note [Add demands for strict constructors] makes it so that the demand on - 'zs' is absent and /strict/: It will get cardinality 'C_10', the empty - interval, rather than 'C_00'. Hence the 'isStrictDmd' check: It guarantees - we never fill in an error-thunk for an absent strict field. - But that also means we emit a rubbish lit for other args that have - cardinality 'C_10' (say, the arg to a bottoming function) where we could've - used an error-thunk, but that's a small price to pay for simplicity. - - 3. We can only emit a RubbishLit if the arg's type @arg_ty@ is mono-rep, e.g. - of the form @TYPE rep@ where @rep@ is not (and doesn't contain) a variable. - Why? Because if we don't know its representation (e.g. size in memory, - register class), we don't know what or how much rubbish to emit in codegen. - 'typeMonoPrimRep_maybe' returns 'Nothing' in this case and we simply fall - back to passing the original parameter to the worker. - - Note that currently this case should not occur, because binders always - have to be representation monomorphic. But in the future, we might allow - levity polymorphism, e.g. a polymorphic levity variable in 'BoxedRep'. - -While (1) and (2) are simply an optimisation in terms of compiler debugging -experience, (3) should be irrelevant in most programs, if not all. - -Historical note: I did try the experiment of using an error thunk for unlifted -things too, relying on the simplifier to drop it as dead code. But this is -fragile - - - It fails when profiling is on, which disables various optimisations - - - It fails when reboxing happens. E.g. - data T = MkT Int Int# - f p@(MkT a _) = ...g p.... - where g is /lazy/ in 'p', but only uses the first component. Then - 'f' is /strict/ in 'p', and only uses the first component. So we only - pass that component to the worker for 'f', which reconstructs 'p' to - pass it to 'g'. Alas we can't say - ...f (MkT a (absentError Int# "blah"))... - because `MkT` is strict in its Int# argument, so we get an absentError - exception when we shouldn't. Very annoying! -} - --- | Tries to find a suitable dummy RHS to bind the given absent identifier to. --- --- If @mk_absent_let _ id == Just wrap@, then @wrap e@ will wrap a let binding --- for @id@ with that RHS around @e@. Otherwise, there could no suitable RHS be --- found. -mk_absent_let :: DynFlags -> Id -> Demand -> Maybe (CoreExpr -> CoreExpr) -mk_absent_let dflags arg dmd - -- The lifted case: Bind 'absentError' for a nice panic message if we are - -- wrong (like we were in #11126). See (1) in Note [Absent fillers] - | Just [LiftedRep] <- mb_mono_prim_reps - , not (isStrictDmd dmd) -- See (2) in Note [Absent fillers] - = Just (Let (NonRec arg panic_rhs)) - - -- The default case for mono rep: Bind @RUBBISH[prim_reps] \@arg_ty@ - -- See Note [Absent fillers], the main part - | Just prim_reps <- mb_mono_prim_reps - = Just (bindNonRec arg (mkTyApps (Lit (mkLitRubbish prim_reps)) [arg_ty])) - - -- Catch all: Either @arg_ty@ wasn't of form @TYPE rep@ or @rep@ wasn't mono rep. - -- See (3) in Note [Absent fillers] - | Nothing <- mb_mono_prim_reps - = WARN( True, text "No absent value for" <+> ppr arg_ty ) - Nothing - where - arg_ty = idType arg - mb_mono_prim_reps = typeMonoPrimRep_maybe arg_ty - - panic_rhs = mkAbsentErrorApp arg_ty msg - - msg = showSDoc (gopt_set dflags Opt_SuppressUniques) - (vcat - [ text "Arg:" <+> ppr arg - , text "Type:" <+> ppr arg_ty - , file_msg - ]) - -- We need to suppress uniques here because otherwise they'd - -- end up in the generated code as strings. This is bad for - -- determinism, because with different uniques the strings - -- will have different lengths and hence different costs for - -- the inliner leading to different inlining. - -- See also Note [Unique Determinism] in GHC.Types.Unique - file_msg = case outputFile dflags of - Nothing -> empty - Just f -> text "In output file " <+> quotes (text f) - -ww_prefix :: FastString -ww_prefix = fsLit "ww" - -mk_ww_local :: Unique -> StrictnessMark -> Scaled Type -> Id --- The StrictnessMark comes form the data constructor and says --- whether this field is strict --- See Note [Record evaluated-ness in worker/wrapper] -mk_ww_local uniq str (Scaled w ty) - = setCaseBndrEvald str $ - mkSysLocalOrCoVar ww_prefix uniq w ty diff --git a/compiler/GHC/Core/Subst.hs b/compiler/GHC/Core/Subst.hs index 520bfd5d16..e0f153287f 100644 --- a/compiler/GHC/Core/Subst.hs +++ b/compiler/GHC/Core/Subst.hs @@ -585,7 +585,7 @@ substCoVarBndr (Subst in_scope id_env tv_env cv_env) cv (TCvSubst in_scope' tv_env' cv_env', cv') -> (Subst in_scope' id_env tv_env' cv_env', cv') --- | See 'Type.substTy' +-- | See 'GHC.Core.Type.substTy'. substTy :: Subst -> Type -> Type substTy subst ty = Type.substTyUnchecked (getTCvSubst subst) ty diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs index cc95b3536e..93b41c1c3b 100644 --- a/compiler/GHC/Core/Unfold.hs +++ b/compiler/GHC/Core/Unfold.hs @@ -960,7 +960,7 @@ certainlyWillInline opts fn_info = case fn_unf of CoreUnfolding { uf_tmpl = expr, uf_guidance = guidance, uf_src = src } | loop_breaker -> Nothing -- Won't inline, so try w/w - | noinline -> Nothing -- See Note [Worker-wrapper for NOINLINE functions] + | noinline -> Nothing -- See Note [Worker/wrapper for NOINLINE functions] | otherwise -> case guidance of UnfNever -> Nothing @@ -1033,7 +1033,7 @@ certainlyWillInline /must/ return Nothing for a large INLINABLE thing, even though we have a stable inlining, so that strictness w/w takes place. It makes a big difference to efficiency, and the w/w pass knows how to transfer the INLINABLE info to the worker; see WorkWrap -Note [Worker-wrapper for INLINABLE functions] +Note [Worker/wrapper for INLINABLE functions] ************************************************************************ * * diff --git a/compiler/GHC/Core/Unfold/Make.hs b/compiler/GHC/Core/Unfold/Make.hs index aa95a13af1..29ec60087c 100644 --- a/compiler/GHC/Core/Unfold/Make.hs +++ b/compiler/GHC/Core/Unfold/Make.hs @@ -88,7 +88,7 @@ mkWwInlineRule opts expr arity , ug_boring_ok = boringCxtNotOk }) mkWorkerUnfolding :: SimpleOpts -> (CoreExpr -> CoreExpr) -> Unfolding -> Unfolding --- See Note [Worker-wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap +-- See Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap mkWorkerUnfolding opts work_fn (CoreUnfolding { uf_src = src, uf_tmpl = tmpl , uf_is_top = top_lvl }) diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs index 6b779ef1aa..ff89358809 100644 --- a/compiler/GHC/Core/Utils.hs +++ b/compiler/GHC/Core/Utils.hs @@ -47,7 +47,7 @@ module GHC.Core.Utils ( exprToType, exprToCoercion_maybe, applyTypeToArgs, applyTypeToArg, dataConRepInstPat, dataConRepFSInstPat, - isEmptyTy, + isEmptyTy, normSplitTyConApp_maybe, -- * Working with ticks stripTicksTop, stripTicksTopE, stripTicksTopT, @@ -89,6 +89,7 @@ import GHC.Builtin.PrimOps import GHC.Types.Id import GHC.Types.Id.Info import GHC.Core.Type as Type +import GHC.Core.FamInstEnv import GHC.Core.Predicate import GHC.Core.TyCo.Rep( TyCoBinder(..), TyBinder ) import GHC.Core.Coercion @@ -2596,6 +2597,17 @@ isEmptyTy ty | otherwise = False +-- | If @normSplitTyConApp_maybe _ ty = Just (tc, tys, co)@ +-- then @ty |> co = tc tys@. It's 'splitTyConApp_maybe', but looks through +-- coercions via 'topNormaliseType_maybe'. Hence the \"norm\" prefix. +normSplitTyConApp_maybe :: FamInstEnvs -> Type -> Maybe (TyCon, [Type], Coercion) +normSplitTyConApp_maybe fam_envs ty + | let (co, ty1) = topNormaliseType_maybe fam_envs ty + `orElse` (mkRepReflCo ty, ty) + , Just (tc, tc_args) <- splitTyConApp_maybe ty1 + = Just (tc, tc_args, co) +normSplitTyConApp_maybe _ _ = Nothing + {- ***************************************************** * diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index 90ba9e4c3f..3c189a8883 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -1267,18 +1267,26 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn -- the object file for one module.) -- Note the nasty duplication with the same computation in compileFile above location <- getLocation src_flavour mod_name - + dt_state <- dynamicTooState dflags let o_file = ml_obj_file location -- The real object file + -- dynamic-too *also* produces the dyn_o_file, so have to check + -- that's there, and if it's not, regenerate both .o and + -- .dyn_o + dyn_o_file = case dt_state of + DT_OK + | not (writeInterfaceOnlyMode dflags) + -> Just (dynamicOutputFile dflags o_file) + _ -> Nothing hi_file = ml_hi_file location hie_file = ml_hie_file location -- Figure out if the source has changed, for recompilation avoidance. -- - -- Setting source_unchanged to True means that M.o (or M.hie) seems + -- Setting source_unchanged to True means that M.o, M.dyn_o (or M.hie) seems -- to be up to date wrt M.hs; so no need to recompile unless imports have -- changed (which the compiler itself figures out). - -- Setting source_unchanged to False tells the compiler that M.o is out of - -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless. + -- Setting source_unchanged to False tells the compiler that M.o or M.dyn_o is out of + -- date wrt M.hs (or M.o/dyn_o doesn't exist) so we must recompile regardless. src_hash <- liftIO $ getFileHash (basename <.> suff) hi_date <- liftIO $ modificationTimeIfExists hi_file @@ -1321,12 +1329,14 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn then return False else sourceModified o_file hi_timestamp ; if o_file_mod then return SourceModified else do { + ; dyn_file_mod <- traverse (flip sourceModified hi_timestamp) dyn_o_file + ; if fromMaybe False dyn_file_mod then return SourceModified else do { ; hie_file_mod <- if gopt Opt_WriteHie dflags then sourceModified hie_file hi_timestamp else pure False ; if hie_file_mod then return SourceModified else do { ; return SourceUnmodified - }}}}}} + }}}}}}} -- run the compiler! let msg hsc_env _ what _ = oneShotMsg hsc_env what diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index 969d63a54b..26ae0c6e0d 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -641,8 +641,6 @@ data DynFlags = DynFlags { interactivePrint :: Maybe String, - nextWrapperNum :: IORef (ModuleEnv Int), - -- | Machine dependent flags (-m\<blah> stuff) sseVersion :: Maybe SseVersion, bmiVersion :: Maybe BmiVersion, @@ -985,9 +983,8 @@ positionIndependent dflags = gopt Opt_PIC dflags || gopt Opt_PIE dflags -- Core optimisation, then the backend (from Core to object code) is executed -- twice. -- --- The implementation is currently rather hacky: recompilation avoidance is --- broken (#17968), we don't clearly separate non-dynamic and dynamic loaded --- interfaces (#9176), etc. +-- The implementation is currently rather hacky, for example, we don't clearly separate non-dynamic +-- and dynamic loaded interfaces (#9176). -- -- To make matters worse, we automatically enable -dynamic-too when some modules -- need Template-Haskell and GHC is dynamically linked (cf @@ -1050,7 +1047,6 @@ initDynFlags dflags = do refDynamicTooFailed <- newIORef (not platformCanGenerateDynamicToo) refRtldInfo <- newIORef Nothing refRtccInfo <- newIORef Nothing - wrapperNum <- newIORef emptyModuleEnv canUseUnicode <- do let enc = localeEncoding str = "‘’" (withCString enc str $ \cstr -> @@ -1068,7 +1064,6 @@ initDynFlags dflags = do (useColor dflags, colScheme dflags) return dflags{ dynamicTooFailed = refDynamicTooFailed, - nextWrapperNum = wrapperNum, useUnicode = useUnicode', useColor = useColor', canUseColor = stderrSupportsAnsiColors, @@ -1231,7 +1226,6 @@ defaultDynFlags mySettings llvmConfig = profAuto = NoProfAuto, callerCcFilters = [], interactivePrint = Nothing, - nextWrapperNum = panic "defaultDynFlags: No nextWrapperNum", sseVersion = Nothing, bmiVersion = Nothing, avx = False, diff --git a/compiler/GHC/Hs.hs b/compiler/GHC/Hs.hs index 17825119e7..0de279e597 100644 --- a/compiler/GHC/Hs.hs +++ b/compiler/GHC/Hs.hs @@ -69,7 +69,7 @@ import Data.Data hiding ( Fixity ) -- All we actually declare here is the top-level structure for a module. data HsModule = HsModule { - hsmodAnn :: EpAnn' AnnsModule, + hsmodAnn :: EpAnn AnnsModule, hsmodLayout :: LayoutInfo, -- ^ Layout info for the module. -- For incomplete modules (e.g. the output of parseHeader), it is NoLayoutInfo. diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs index 72f54828ee..6c2ed3c167 100644 --- a/compiler/GHC/Hs/Binds.hs +++ b/compiler/GHC/Hs/Binds.hs @@ -69,8 +69,8 @@ Global bindings (where clauses) -- the ...LR datatypes are parametrized by two id types, -- one for the left and one for the right. -type instance XHsValBinds (GhcPass pL) (GhcPass pR) = EpAnn' AnnList -type instance XHsIPBinds (GhcPass pL) (GhcPass pR) = EpAnn' AnnList +type instance XHsValBinds (GhcPass pL) (GhcPass pR) = EpAnn AnnList +type instance XHsIPBinds (GhcPass pL) (GhcPass pR) = EpAnn AnnList type instance XEmptyLocalBinds (GhcPass pL) (GhcPass pR) = NoExtField type instance XXHsLocalBindsLR (GhcPass pL) (GhcPass pR) = NoExtCon @@ -93,7 +93,7 @@ type instance XFunBind (GhcPass pL) GhcPs = NoExtField type instance XFunBind (GhcPass pL) GhcRn = NameSet -- Free variables type instance XFunBind (GhcPass pL) GhcTc = HsWrapper -- See comments on FunBind.fun_ext -type instance XPatBind GhcPs (GhcPass pR) = EpAnn +type instance XPatBind GhcPs (GhcPass pR) = EpAnn [AddEpAnn] type instance XPatBind GhcRn (GhcPass pR) = NameSet -- Free variables type instance XPatBind GhcTc (GhcPass pR) = Type -- Type of the GRHSs @@ -105,7 +105,7 @@ type instance XXHsBindsLR (GhcPass pL) (GhcPass pR) = NoExtCon type instance XABE (GhcPass p) = NoExtField type instance XXABExport (GhcPass p) = NoExtCon -type instance XPSB (GhcPass idL) GhcPs = EpAnn +type instance XPSB (GhcPass idL) GhcPs = EpAnn [AddEpAnn] type instance XPSB (GhcPass idL) GhcRn = NameSet type instance XPSB (GhcPass idL) GhcTc = NameSet @@ -552,7 +552,7 @@ isEmptyIPBindsPR (IPBinds _ is) = null is isEmptyIPBindsTc :: HsIPBinds GhcTc -> Bool isEmptyIPBindsTc (IPBinds ds is) = null is && isEmptyTcEvBinds ds -type instance XCIPBind (GhcPass p) = EpAnn +type instance XCIPBind (GhcPass p) = EpAnn [AddEpAnn] type instance XXIPBind (GhcPass p) = NoExtCon instance OutputableBndrId p @@ -574,17 +574,17 @@ instance OutputableBndrId p => Outputable (IPBind (GhcPass p)) where ************************************************************************ -} -type instance XTypeSig (GhcPass p) = EpAnn' AnnSig -type instance XPatSynSig (GhcPass p) = EpAnn' AnnSig -type instance XClassOpSig (GhcPass p) = EpAnn' AnnSig +type instance XTypeSig (GhcPass p) = EpAnn AnnSig +type instance XPatSynSig (GhcPass p) = EpAnn AnnSig +type instance XClassOpSig (GhcPass p) = EpAnn AnnSig type instance XIdSig (GhcPass p) = NoExtField -- No anns, generated -type instance XFixSig (GhcPass p) = EpAnn -type instance XInlineSig (GhcPass p) = EpAnn -type instance XSpecSig (GhcPass p) = EpAnn -type instance XSpecInstSig (GhcPass p) = EpAnn -type instance XMinimalSig (GhcPass p) = EpAnn -type instance XSCCFunSig (GhcPass p) = EpAnn -type instance XCompleteMatchSig (GhcPass p) = EpAnn +type instance XFixSig (GhcPass p) = EpAnn [AddEpAnn] +type instance XInlineSig (GhcPass p) = EpAnn [AddEpAnn] +type instance XSpecSig (GhcPass p) = EpAnn [AddEpAnn] +type instance XSpecInstSig (GhcPass p) = EpAnn [AddEpAnn] +type instance XMinimalSig (GhcPass p) = EpAnn [AddEpAnn] +type instance XSCCFunSig (GhcPass p) = EpAnn [AddEpAnn] +type instance XCompleteMatchSig (GhcPass p) = EpAnn [AddEpAnn] type instance XXSig (GhcPass p) = NoExtCon diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs index b3eac48499..9f3f6469e5 100644 --- a/compiler/GHC/Hs/Decls.hs +++ b/compiler/GHC/Hs/Decls.hs @@ -325,22 +325,22 @@ instance OutputableBndrId p type instance XFamDecl (GhcPass _) = NoExtField -type instance XSynDecl GhcPs = EpAnn +type instance XSynDecl GhcPs = EpAnn [AddEpAnn] type instance XSynDecl GhcRn = NameSet -- FVs type instance XSynDecl GhcTc = NameSet -- FVs -type instance XDataDecl GhcPs = EpAnn -- AZ: used? +type instance XDataDecl GhcPs = EpAnn [AddEpAnn] -- AZ: used? type instance XDataDecl GhcRn = DataDeclRn type instance XDataDecl GhcTc = DataDeclRn -type instance XClassDecl GhcPs = (EpAnn, AnnSortKey, LayoutInfo) -- See Note [Class LayoutInfo] +type instance XClassDecl GhcPs = (EpAnn [AddEpAnn], AnnSortKey, LayoutInfo) -- See Note [Class LayoutInfo] -- TODO:AZ:tidy up AnnSortKey above type instance XClassDecl GhcRn = NameSet -- FVs type instance XClassDecl GhcTc = NameSet -- FVs type instance XXTyClDecl (GhcPass _) = NoExtCon -type instance XCTyFamInstDecl (GhcPass _) = EpAnn +type instance XCTyFamInstDecl (GhcPass _) = EpAnn [AddEpAnn] type instance XXTyFamInstDecl (GhcPass _) = NoExtCon -- Dealing with names @@ -463,7 +463,7 @@ pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } }) instance OutputableBndrId p => Outputable (FunDep (GhcPass p)) where ppr = pprFunDep -type instance XCFunDep (GhcPass _) = EpAnn +type instance XCFunDep (GhcPass _) = EpAnn [AddEpAnn] type instance XXFunDep (GhcPass _) = NoExtCon pprFundeps :: OutputableBndrId p => [FunDep (GhcPass p)] -> SDoc @@ -497,7 +497,7 @@ type instance XCKindSig (GhcPass _) = NoExtField type instance XTyVarSig (GhcPass _) = NoExtField type instance XXFamilyResultSig (GhcPass _) = NoExtCon -type instance XCFamilyDecl (GhcPass _) = EpAnn +type instance XCFamilyDecl (GhcPass _) = EpAnn [AddEpAnn] type instance XXFamilyDecl (GhcPass _) = NoExtCon @@ -524,7 +524,7 @@ resultVariableName _ = Nothing ------------- Pretty printing FamilyDecls ----------- -type instance XCInjectivityAnn (GhcPass _) = EpAnn +type instance XCInjectivityAnn (GhcPass _) = EpAnn [AddEpAnn] type instance XXInjectivityAnn (GhcPass _) = NoExtCon instance OutputableBndrId p @@ -568,10 +568,10 @@ instance OutputableBndrId p * * ********************************************************************* -} -type instance XCHsDataDefn (GhcPass _) = EpAnn +type instance XCHsDataDefn (GhcPass _) = EpAnn [AddEpAnn] type instance XXHsDataDefn (GhcPass _) = NoExtCon -type instance XCHsDerivingClause (GhcPass _) = EpAnn +type instance XCHsDerivingClause (GhcPass _) = EpAnn [AddEpAnn] type instance XXHsDerivingClause (GhcPass _) = NoExtCon instance OutputableBndrId p @@ -598,7 +598,7 @@ instance OutputableBndrId p => Outputable (DerivClauseTys (GhcPass p)) where ppr (DctSingle _ ty) = ppr ty ppr (DctMulti _ tys) = parens (interpp'SP tys) -type instance XStandaloneKindSig GhcPs = EpAnn +type instance XStandaloneKindSig GhcPs = EpAnn [AddEpAnn] type instance XStandaloneKindSig GhcRn = NoExtField type instance XStandaloneKindSig GhcTc = NoExtField @@ -607,8 +607,8 @@ type instance XXStandaloneKindSig (GhcPass p) = NoExtCon standaloneKindSigName :: StandaloneKindSig (GhcPass p) -> IdP (GhcPass p) standaloneKindSigName (StandaloneKindSig _ lname _) = unLoc lname -type instance XConDeclGADT (GhcPass _) = EpAnn -type instance XConDeclH98 (GhcPass _) = EpAnn +type instance XConDeclGADT (GhcPass _) = EpAnn [AddEpAnn] +type instance XConDeclH98 (GhcPass _) = EpAnn [AddEpAnn] type instance XXConDecl (GhcPass _) = NoExtCon @@ -724,14 +724,14 @@ ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc) ************************************************************************ -} -type instance XCFamEqn (GhcPass _) r = EpAnn +type instance XCFamEqn (GhcPass _) r = EpAnn [AddEpAnn] type instance XXFamEqn (GhcPass _) r = NoExtCon type instance Anno (FamEqn (GhcPass p) _) = SrcSpanAnnA ----------------- Class instances ------------- -type instance XCClsInstDecl GhcPs = (EpAnn, AnnSortKey) -- TODO:AZ:tidy up +type instance XCClsInstDecl GhcPs = (EpAnn [AddEpAnn], AnnSortKey) -- TODO:AZ:tidy up type instance XCClsInstDecl GhcRn = NoExtField type instance XCClsInstDecl GhcTc = NoExtField @@ -741,7 +741,7 @@ type instance XXClsInstDecl (GhcPass _) = NoExtCon type instance XClsInstD (GhcPass _) = NoExtField -type instance XDataFamInstD GhcPs = EpAnn +type instance XDataFamInstD GhcPs = EpAnn [AddEpAnn] type instance XDataFamInstD GhcRn = NoExtField type instance XDataFamInstD GhcTc = NoExtField @@ -887,7 +887,7 @@ instDeclDataFamInsts inst_decls ************************************************************************ -} -type instance XCDerivDecl (GhcPass _) = EpAnn +type instance XCDerivDecl (GhcPass _) = EpAnn [AddEpAnn] type instance XXDerivDecl (GhcPass _) = NoExtCon type instance Anno OverlapMode = SrcSpanAnnP @@ -911,15 +911,15 @@ instance OutputableBndrId p ************************************************************************ -} -type instance XStockStrategy GhcPs = EpAnn +type instance XStockStrategy GhcPs = EpAnn [AddEpAnn] type instance XStockStrategy GhcRn = NoExtField type instance XStockStrategy GhcTc = NoExtField -type instance XAnyClassStrategy GhcPs = EpAnn +type instance XAnyClassStrategy GhcPs = EpAnn [AddEpAnn] type instance XAnyClassStrategy GhcRn = NoExtField type instance XAnyClassStrategy GhcTc = NoExtField -type instance XNewtypeStrategy GhcPs = EpAnn +type instance XNewtypeStrategy GhcPs = EpAnn [AddEpAnn] type instance XNewtypeStrategy GhcRn = NoExtField type instance XNewtypeStrategy GhcTc = NoExtField @@ -927,7 +927,7 @@ type instance XViaStrategy GhcPs = XViaStrategyPs type instance XViaStrategy GhcRn = LHsSigType GhcRn type instance XViaStrategy GhcTc = Type -data XViaStrategyPs = XViaStrategyPs EpAnn (LHsSigType GhcPs) +data XViaStrategyPs = XViaStrategyPs (EpAnn [AddEpAnn]) (LHsSigType GhcPs) instance OutputableBndrId p => Outputable (DerivStrategy (GhcPass p)) where @@ -966,7 +966,7 @@ mapDerivStrategy f ds = foldDerivStrategy ds (ViaStrategy . f) ds ************************************************************************ -} -type instance XCDefaultDecl GhcPs = EpAnn +type instance XCDefaultDecl GhcPs = EpAnn [AddEpAnn] type instance XCDefaultDecl GhcRn = NoExtField type instance XCDefaultDecl GhcTc = NoExtField @@ -985,11 +985,11 @@ instance OutputableBndrId p ************************************************************************ -} -type instance XForeignImport GhcPs = EpAnn +type instance XForeignImport GhcPs = EpAnn [AddEpAnn] type instance XForeignImport GhcRn = NoExtField type instance XForeignImport GhcTc = Coercion -type instance XForeignExport GhcPs = EpAnn +type instance XForeignExport GhcPs = EpAnn [AddEpAnn] type instance XForeignExport GhcRn = NoExtField type instance XForeignExport GhcTc = Coercion @@ -1012,13 +1012,13 @@ instance OutputableBndrId p ************************************************************************ -} -type instance XCRuleDecls GhcPs = EpAnn +type instance XCRuleDecls GhcPs = EpAnn [AddEpAnn] type instance XCRuleDecls GhcRn = NoExtField type instance XCRuleDecls GhcTc = NoExtField type instance XXRuleDecls (GhcPass _) = NoExtCon -type instance XHsRule GhcPs = EpAnn' HsRuleAnn +type instance XHsRule GhcPs = EpAnn HsRuleAnn type instance XHsRule GhcRn = HsRuleRn type instance XHsRule GhcTc = HsRuleRn @@ -1040,8 +1040,8 @@ data HsRuleAnn flattenRuleDecls :: [LRuleDecls (GhcPass p)] -> [LRuleDecl (GhcPass p)] flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls -type instance XCRuleBndr (GhcPass _) = EpAnn -type instance XRuleBndrSig (GhcPass _) = EpAnn +type instance XCRuleBndr (GhcPass _) = EpAnn [AddEpAnn] +type instance XRuleBndrSig (GhcPass _) = EpAnn [AddEpAnn] type instance XXRuleBndr (GhcPass _) = NoExtCon instance (OutputableBndrId p) => Outputable (RuleDecls (GhcPass p)) where @@ -1079,13 +1079,13 @@ instance (OutputableBndrId p) => Outputable (RuleBndr (GhcPass p)) where ************************************************************************ -} -type instance XWarnings GhcPs = EpAnn +type instance XWarnings GhcPs = EpAnn [AddEpAnn] type instance XWarnings GhcRn = NoExtField type instance XWarnings GhcTc = NoExtField type instance XXWarnDecls (GhcPass _) = NoExtCon -type instance XWarning (GhcPass _) = EpAnn +type instance XWarning (GhcPass _) = EpAnn [AddEpAnn] type instance XXWarnDecl (GhcPass _) = NoExtCon @@ -1109,7 +1109,7 @@ instance OutputableBndrId p ************************************************************************ -} -type instance XHsAnnotation (GhcPass _) = EpAnn' AnnPragma +type instance XHsAnnotation (GhcPass _) = EpAnn AnnPragma type instance XXAnnDecl (GhcPass _) = NoExtCon instance (OutputableBndrId p) => Outputable (AnnDecl (GhcPass p)) where @@ -1131,7 +1131,7 @@ pprAnnProvenance (TypeAnnProvenance (L _ name)) ************************************************************************ -} -type instance XCRoleAnnotDecl GhcPs = EpAnn +type instance XCRoleAnnotDecl GhcPs = EpAnn [AddEpAnn] type instance XCRoleAnnotDecl GhcRn = NoExtField type instance XCRoleAnnotDecl GhcTc = NoExtField diff --git a/compiler/GHC/Hs/Dump.hs b/compiler/GHC/Hs/Dump.hs index 8a69ad0c60..9be0f96640 100644 --- a/compiler/GHC/Hs/Dump.hs +++ b/compiler/GHC/Hs/Dump.hs @@ -136,12 +136,13 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0 BlankSrcSpanFile -> parens $ text "SourceText" <+> text src _ -> parens $ text "SourceText" <+> text "blanked" - epaAnchor :: EpaAnchor -> SDoc - epaAnchor (AR r) = parens $ text "AR" <+> realSrcSpan r - epaAnchor (AD d) = parens $ text "AD" <+> deltaPos d + epaAnchor :: EpaLocation -> SDoc + epaAnchor (EpaSpan r) = parens $ text "EpaSpan" <+> realSrcSpan r + epaAnchor (EpaDelta d) = parens $ text "EpaDelta" <+> deltaPos d deltaPos :: DeltaPos -> SDoc - deltaPos (DP l c) = parens $ text "DP" <+> ppr l <+> ppr c + deltaPos (SameLine c) = parens $ text "SameLine" <+> ppr c + deltaPos (DifferentLine l c) = parens $ text "DifferentLine" <+> ppr l <+> ppr c name :: Name -> SDoc name nm = braces $ text "Name:" <+> ppr nm @@ -223,38 +224,38 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0 -- ------------------------- - annotation :: EpAnn -> SDoc - annotation = annotation' (text "EpAnn") + annotation :: EpAnn [AddEpAnn] -> SDoc + annotation = annotation' (text "EpAnn [AddEpAnn]") - annotationModule :: EpAnn' AnnsModule -> SDoc - annotationModule = annotation' (text "EpAnn' AnnsModule") + annotationModule :: EpAnn AnnsModule -> SDoc + annotationModule = annotation' (text "EpAnn AnnsModule") - annotationAddEpAnn :: EpAnn' AddEpAnn -> SDoc - annotationAddEpAnn = annotation' (text "EpAnn' AddEpAnn") + annotationAddEpAnn :: EpAnn AddEpAnn -> SDoc + annotationAddEpAnn = annotation' (text "EpAnn AddEpAnn") - annotationGrhsAnn :: EpAnn' GrhsAnn -> SDoc - annotationGrhsAnn = annotation' (text "EpAnn' GrhsAnn") + annotationGrhsAnn :: EpAnn GrhsAnn -> SDoc + annotationGrhsAnn = annotation' (text "EpAnn GrhsAnn") - annotationEpAnnHsCase :: EpAnn' EpAnnHsCase -> SDoc - annotationEpAnnHsCase = annotation' (text "EpAnn' EpAnnHsCase") + annotationEpAnnHsCase :: EpAnn EpAnnHsCase -> SDoc + annotationEpAnnHsCase = annotation' (text "EpAnn EpAnnHsCase") - annotationEpAnnHsLet :: EpAnn' AnnsLet -> SDoc - annotationEpAnnHsLet = annotation' (text "EpAnn' AnnsLet") + annotationEpAnnHsLet :: EpAnn AnnsLet -> SDoc + annotationEpAnnHsLet = annotation' (text "EpAnn AnnsLet") - annotationAnnList :: EpAnn' AnnList -> SDoc - annotationAnnList = annotation' (text "EpAnn' AnnList") + annotationAnnList :: EpAnn AnnList -> SDoc + annotationAnnList = annotation' (text "EpAnn AnnList") - annotationEpAnnImportDecl :: EpAnn' EpAnnImportDecl -> SDoc - annotationEpAnnImportDecl = annotation' (text "EpAnn' EpAnnImportDecl") + annotationEpAnnImportDecl :: EpAnn EpAnnImportDecl -> SDoc + annotationEpAnnImportDecl = annotation' (text "EpAnn EpAnnImportDecl") - annotationAnnParen :: EpAnn' AnnParen -> SDoc - annotationAnnParen = annotation' (text "EpAnn' AnnParen") + annotationAnnParen :: EpAnn AnnParen -> SDoc + annotationAnnParen = annotation' (text "EpAnn AnnParen") - annotationTrailingAnn :: EpAnn' TrailingAnn -> SDoc - annotationTrailingAnn = annotation' (text "EpAnn' TrailingAnn") + annotationTrailingAnn :: EpAnn TrailingAnn -> SDoc + annotationTrailingAnn = annotation' (text "EpAnn TrailingAnn") annotation' :: forall a .(Data a, Typeable a) - => SDoc -> EpAnn' a -> SDoc + => SDoc -> EpAnn a -> SDoc annotation' tag anns = case ba of BlankEpAnnotations -> parens (text "blanked:" <+> tag) NoBlankEpAnnotations -> parens $ text (showConstr (toConstr anns)) @@ -262,19 +263,19 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0 -- ------------------------- - srcSpanAnnA :: SrcSpanAnn' (EpAnn' AnnListItem) -> SDoc + srcSpanAnnA :: SrcSpanAnn' (EpAnn AnnListItem) -> SDoc srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA") - srcSpanAnnL :: SrcSpanAnn' (EpAnn' AnnList) -> SDoc + srcSpanAnnL :: SrcSpanAnn' (EpAnn AnnList) -> SDoc srcSpanAnnL = locatedAnn'' (text "SrcSpanAnnL") - srcSpanAnnP :: SrcSpanAnn' (EpAnn' AnnPragma) -> SDoc + srcSpanAnnP :: SrcSpanAnn' (EpAnn AnnPragma) -> SDoc srcSpanAnnP = locatedAnn'' (text "SrcSpanAnnP") - srcSpanAnnC :: SrcSpanAnn' (EpAnn' AnnContext) -> SDoc + srcSpanAnnC :: SrcSpanAnn' (EpAnn AnnContext) -> SDoc srcSpanAnnC = locatedAnn'' (text "SrcSpanAnnC") - srcSpanAnnN :: SrcSpanAnn' (EpAnn' NameAnn) -> SDoc + srcSpanAnnN :: SrcSpanAnn' (EpAnn NameAnn) -> SDoc srcSpanAnnN = locatedAnn'' (text "SrcSpanAnnN") locatedAnn'' :: forall a. (Typeable a, Data a) diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index 436da995a7..bf415f7264 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -207,14 +207,14 @@ could only do that if the extension field was strict (#18764) -- API Annotations types data EpAnnHsCase = EpAnnHsCase - { hsCaseAnnCase :: EpaAnchor - , hsCaseAnnOf :: EpaAnchor + { hsCaseAnnCase :: EpaLocation + , hsCaseAnnOf :: EpaLocation , hsCaseAnnsRest :: [AddEpAnn] } deriving Data data EpAnnUnboundVar = EpAnnUnboundVar - { hsUnboundBackquotes :: (EpaAnchor, EpaAnchor) - , hsUnboundHole :: EpaAnchor + { hsUnboundBackquotes :: (EpaLocation, EpaLocation) + , hsUnboundHole :: EpaLocation } deriving Data type instance XVar (GhcPass _) = NoExtField @@ -232,7 +232,7 @@ type instance XOverLabel GhcTc = Void -- See Note [Constructor cannot occur type instance XVar (GhcPass _) = NoExtField -type instance XUnboundVar GhcPs = EpAnn' EpAnnUnboundVar +type instance XUnboundVar GhcPs = EpAnn EpAnnUnboundVar type instance XUnboundVar GhcRn = NoExtField type instance XUnboundVar GhcTc = HoleExprRef -- We really don't need the whole HoleExprRef; just the IORef EvTerm @@ -248,7 +248,7 @@ type instance XLitE (GhcPass _) = EpAnnCO type instance XLam (GhcPass _) = NoExtField -type instance XLamCase (GhcPass _) = EpAnn +type instance XLamCase (GhcPass _) = EpAnn [AddEpAnn] type instance XApp (GhcPass _) = EpAnnCO type instance XAppTypeE GhcPs = SrcSpan -- Where the `@` lives @@ -257,7 +257,7 @@ type instance XAppTypeE GhcTc = Type -- OpApp not present in GhcTc pass; see GHC.Rename.Expr -- Note [Handling overloaded and rebindable constructs] -type instance XOpApp GhcPs = EpAnn +type instance XOpApp GhcPs = EpAnn [AddEpAnn] type instance XOpApp GhcRn = Fixity type instance XOpApp GhcTc = Void -- See Note [Constructor cannot occur] @@ -271,41 +271,41 @@ type instance XSectionL GhcTc = Void -- See Note [Constructor cannot occur type instance XSectionR GhcTc = Void -- See Note [Constructor cannot occur] -type instance XNegApp GhcPs = EpAnn +type instance XNegApp GhcPs = EpAnn [AddEpAnn] type instance XNegApp GhcRn = NoExtField type instance XNegApp GhcTc = NoExtField -type instance XPar (GhcPass _) = EpAnn' AnnParen +type instance XPar (GhcPass _) = EpAnn AnnParen -type instance XExplicitTuple GhcPs = EpAnn +type instance XExplicitTuple GhcPs = EpAnn [AddEpAnn] type instance XExplicitTuple GhcRn = NoExtField type instance XExplicitTuple GhcTc = NoExtField -type instance XExplicitSum GhcPs = EpAnn' AnnExplicitSum +type instance XExplicitSum GhcPs = EpAnn AnnExplicitSum type instance XExplicitSum GhcRn = NoExtField type instance XExplicitSum GhcTc = [Type] -type instance XCase GhcPs = EpAnn' EpAnnHsCase +type instance XCase GhcPs = EpAnn EpAnnHsCase type instance XCase GhcRn = NoExtField type instance XCase GhcTc = NoExtField -type instance XIf GhcPs = EpAnn +type instance XIf GhcPs = EpAnn [AddEpAnn] type instance XIf GhcRn = NoExtField type instance XIf GhcTc = NoExtField -type instance XMultiIf GhcPs = EpAnn +type instance XMultiIf GhcPs = EpAnn [AddEpAnn] type instance XMultiIf GhcRn = NoExtField type instance XMultiIf GhcTc = Type -type instance XLet GhcPs = EpAnn' AnnsLet +type instance XLet GhcPs = EpAnn AnnsLet type instance XLet GhcRn = NoExtField type instance XLet GhcTc = NoExtField -type instance XDo GhcPs = EpAnn' AnnList +type instance XDo GhcPs = EpAnn AnnList type instance XDo GhcRn = NoExtField type instance XDo GhcTc = Type -type instance XExplicitList GhcPs = EpAnn' AnnList +type instance XExplicitList GhcPs = EpAnn AnnList type instance XExplicitList GhcRn = NoExtField type instance XExplicitList GhcTc = Type -- GhcPs: ExplicitList includes all source-level @@ -316,11 +316,11 @@ type instance XExplicitList GhcTc = Type -- See Note [Handling overloaded and rebindable constructs] -- in GHC.Rename.Expr -type instance XRecordCon GhcPs = EpAnn +type instance XRecordCon GhcPs = EpAnn [AddEpAnn] type instance XRecordCon GhcRn = NoExtField type instance XRecordCon GhcTc = PostTcExpr -- Instantiated constructor function -type instance XRecordUpd GhcPs = EpAnn +type instance XRecordUpd GhcPs = EpAnn [AddEpAnn] type instance XRecordUpd GhcRn = NoExtField type instance XRecordUpd GhcTc = RecordUpdTc @@ -330,29 +330,29 @@ type instance XGetField GhcTc = Void -- HsGetField is eliminated by the renamer. See [Handling overloaded -- and rebindable constructs]. -type instance XProjection GhcPs = EpAnn' AnnProjection +type instance XProjection GhcPs = EpAnn AnnProjection type instance XProjection GhcRn = NoExtField type instance XProjection GhcTc = Void -- HsProjection is eliminated by the renamer. See [Handling overloaded -- and rebindable constructs]. -type instance XExprWithTySig GhcPs = EpAnn +type instance XExprWithTySig GhcPs = EpAnn [AddEpAnn] type instance XExprWithTySig GhcRn = NoExtField type instance XExprWithTySig GhcTc = NoExtField -type instance XArithSeq GhcPs = EpAnn +type instance XArithSeq GhcPs = EpAnn [AddEpAnn] type instance XArithSeq GhcRn = NoExtField type instance XArithSeq GhcTc = PostTcExpr -type instance XBracket (GhcPass _) = EpAnn +type instance XBracket (GhcPass _) = EpAnn [AddEpAnn] type instance XRnBracketOut (GhcPass _) = NoExtField type instance XTcBracketOut (GhcPass _) = NoExtField type instance XSpliceE (GhcPass _) = EpAnnCO -type instance XProc (GhcPass _) = EpAnn +type instance XProc (GhcPass _) = EpAnn [AddEpAnn] -type instance XStatic GhcPs = EpAnn +type instance XStatic GhcPs = EpAnn [AddEpAnn] type instance XStatic GhcRn = NameSet type instance XStatic GhcTc = NameSet @@ -378,40 +378,40 @@ data XXExprGhcTc data AnnExplicitSum = AnnExplicitSum { - aesOpen :: EpaAnchor, - aesBarsBefore :: [EpaAnchor], - aesBarsAfter :: [EpaAnchor], - aesClose :: EpaAnchor + aesOpen :: EpaLocation, + aesBarsBefore :: [EpaLocation], + aesBarsAfter :: [EpaLocation], + aesClose :: EpaLocation } deriving Data data AnnsLet = AnnsLet { - alLet :: EpaAnchor, - alIn :: EpaAnchor + alLet :: EpaLocation, + alIn :: EpaLocation } deriving Data data AnnFieldLabel = AnnFieldLabel { - afDot :: Maybe EpaAnchor + afDot :: Maybe EpaLocation } deriving Data data AnnProjection = AnnProjection { - apOpen :: EpaAnchor, -- ^ '(' - apClose :: EpaAnchor -- ^ ')' + apOpen :: EpaLocation, -- ^ '(' + apClose :: EpaLocation -- ^ ')' } deriving Data -- --------------------------------------------------------------------- -type instance XSCC (GhcPass _) = EpAnn' AnnPragma +type instance XSCC (GhcPass _) = EpAnn AnnPragma type instance XXPragE (GhcPass _) = NoExtCon -type instance XCHsFieldLabel (GhcPass _) = EpAnn' AnnFieldLabel +type instance XCHsFieldLabel (GhcPass _) = EpAnn AnnFieldLabel type instance XXHsFieldLabel (GhcPass _) = NoExtCon -type instance XPresent (GhcPass _) = EpAnn +type instance XPresent (GhcPass _) = EpAnn [AddEpAnn] -type instance XMissing GhcPs = EpAnn' EpaAnchor +type instance XMissing GhcPs = EpAnn EpaLocation type instance XMissing GhcRn = NoExtField type instance XMissing GhcTc = Scaled Type @@ -981,33 +981,33 @@ instance (Outputable a, Outputable b) => Outputable (HsExpansion a b) where ************************************************************************ -} -type instance XCmdArrApp GhcPs = EpAnn' AddEpAnn +type instance XCmdArrApp GhcPs = EpAnn AddEpAnn type instance XCmdArrApp GhcRn = NoExtField type instance XCmdArrApp GhcTc = Type -type instance XCmdArrForm GhcPs = EpAnn' AnnList +type instance XCmdArrForm GhcPs = EpAnn AnnList type instance XCmdArrForm GhcRn = NoExtField type instance XCmdArrForm GhcTc = NoExtField type instance XCmdApp (GhcPass _) = EpAnnCO type instance XCmdLam (GhcPass _) = NoExtField -type instance XCmdPar (GhcPass _) = EpAnn' AnnParen +type instance XCmdPar (GhcPass _) = EpAnn AnnParen -type instance XCmdCase GhcPs = EpAnn' EpAnnHsCase +type instance XCmdCase GhcPs = EpAnn EpAnnHsCase type instance XCmdCase GhcRn = NoExtField type instance XCmdCase GhcTc = NoExtField -type instance XCmdLamCase (GhcPass _) = EpAnn +type instance XCmdLamCase (GhcPass _) = EpAnn [AddEpAnn] -type instance XCmdIf GhcPs = EpAnn +type instance XCmdIf GhcPs = EpAnn [AddEpAnn] type instance XCmdIf GhcRn = NoExtField type instance XCmdIf GhcTc = NoExtField -type instance XCmdLet GhcPs = EpAnn' AnnsLet +type instance XCmdLet GhcPs = EpAnn AnnsLet type instance XCmdLet GhcRn = NoExtField type instance XCmdLet GhcTc = NoExtField -type instance XCmdDo GhcPs = EpAnn' AnnList +type instance XCmdDo GhcPs = EpAnn AnnList type instance XCmdDo GhcRn = NoExtField type instance XCmdDo GhcTc = Type @@ -1152,7 +1152,7 @@ type instance XMG GhcTc b = MatchGroupTc type instance XXMatchGroup (GhcPass _) b = NoExtCon -type instance XCMatch (GhcPass _) b = EpAnn +type instance XCMatch (GhcPass _) b = EpAnn [AddEpAnn] type instance XXMatch (GhcPass _) b = NoExtCon instance (OutputableBndrId pr, Outputable body) @@ -1186,11 +1186,11 @@ type instance XXGRHSs (GhcPass _) _ = NoExtCon data GrhsAnn = GrhsAnn { - ga_vbar :: Maybe EpaAnchor, -- TODO:AZ do we need this? + ga_vbar :: Maybe EpaLocation, -- TODO:AZ do we need this? ga_sep :: AddEpAnn -- ^ Match separator location } deriving (Data) -type instance XCGRHS (GhcPass _) _ = EpAnn' GrhsAnn +type instance XCGRHS (GhcPass _) _ = EpAnn GrhsAnn -- Location of matchSeparator -- TODO:AZ does this belong on the GRHS, or GRHSs? @@ -1304,7 +1304,7 @@ data RecStmtTc = type instance XLastStmt (GhcPass _) (GhcPass _) b = NoExtField -type instance XBindStmt (GhcPass _) GhcPs b = EpAnn +type instance XBindStmt (GhcPass _) GhcPs b = EpAnn [AddEpAnn] type instance XBindStmt (GhcPass _) GhcRn b = XBindStmtRn type instance XBindStmt (GhcPass _) GhcTc b = XBindStmtTc @@ -1328,17 +1328,17 @@ type instance XBodyStmt (GhcPass _) GhcPs b = NoExtField type instance XBodyStmt (GhcPass _) GhcRn b = NoExtField type instance XBodyStmt (GhcPass _) GhcTc b = Type -type instance XLetStmt (GhcPass _) (GhcPass _) b = EpAnn +type instance XLetStmt (GhcPass _) (GhcPass _) b = EpAnn [AddEpAnn] type instance XParStmt (GhcPass _) GhcPs b = NoExtField type instance XParStmt (GhcPass _) GhcRn b = NoExtField type instance XParStmt (GhcPass _) GhcTc b = Type -type instance XTransStmt (GhcPass _) GhcPs b = EpAnn +type instance XTransStmt (GhcPass _) GhcPs b = EpAnn [AddEpAnn] type instance XTransStmt (GhcPass _) GhcRn b = NoExtField type instance XTransStmt (GhcPass _) GhcTc b = Type -type instance XRecStmt (GhcPass _) GhcPs b = EpAnn' AnnList +type instance XRecStmt (GhcPass _) GhcPs b = EpAnn AnnList type instance XRecStmt (GhcPass _) GhcRn b = NoExtField type instance XRecStmt (GhcPass _) GhcTc b = RecStmtTc @@ -1523,8 +1523,8 @@ pprQuals quals = interpp'SP quals newtype HsSplicedT = HsSplicedT DelayedSplice deriving (Data) -type instance XTypedSplice (GhcPass _) = EpAnn -type instance XUntypedSplice (GhcPass _) = EpAnn +type instance XTypedSplice (GhcPass _) = EpAnn [AddEpAnn] +type instance XUntypedSplice (GhcPass _) = EpAnn [AddEpAnn] type instance XQuasiQuote (GhcPass _) = NoExtField type instance XSpliced (GhcPass _) = NoExtField type instance XXSplice GhcPs = NoExtCon @@ -1838,6 +1838,6 @@ type instance Anno (HsSplice (GhcPass p)) = SrcSpanAnnA type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr))))] = SrcSpanAnnL type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))] = SrcSpanAnnL -instance (Anno a ~ SrcSpanAnn' (EpAnn' an)) +instance (Anno a ~ SrcSpanAnn' (EpAnn an)) => WrapXRec (GhcPass p) a where wrapXRec = noLocA diff --git a/compiler/GHC/Hs/Extension.hs b/compiler/GHC/Hs/Extension.hs index 1134e2520a..e28bcddbf1 100644 --- a/compiler/GHC/Hs/Extension.hs +++ b/compiler/GHC/Hs/Extension.hs @@ -101,7 +101,7 @@ type instance Anno RdrName = SrcSpanAnnN type instance Anno Name = SrcSpanAnnN type instance Anno Id = SrcSpanAnnN -type IsSrcSpanAnn p a = ( Anno (IdGhcP p) ~ SrcSpanAnn' (EpAnn' a), +type IsSrcSpanAnn p a = ( Anno (IdGhcP p) ~ SrcSpanAnn' (EpAnn a), IsPass p) instance UnXRec (GhcPass p) where diff --git a/compiler/GHC/Hs/ImpExp.hs b/compiler/GHC/Hs/ImpExp.hs index 103359281b..55b5af7bc9 100644 --- a/compiler/GHC/Hs/ImpExp.hs +++ b/compiler/GHC/Hs/ImpExp.hs @@ -64,9 +64,9 @@ data ImportDeclQualifiedStyle -- | Given two possible located 'qualified' tokens, compute a style -- (in a conforming Haskell program only one of the two can be not -- 'Nothing'). This is called from "GHC.Parser". -importDeclQualifiedStyle :: Maybe EpaAnchor - -> Maybe EpaAnchor - -> (Maybe EpaAnchor, ImportDeclQualifiedStyle) +importDeclQualifiedStyle :: Maybe EpaLocation + -> Maybe EpaLocation + -> (Maybe EpaLocation, ImportDeclQualifiedStyle) importDeclQualifiedStyle mPre mPost = if isJust mPre then (mPre, QualifiedPre) else if isJust mPost then (mPost,QualifiedPost) else (Nothing, NotQualified) @@ -113,7 +113,7 @@ data ImportDecl pass -- For details on above see note [exact print annotations] in GHC.Parser.Annotation -type instance XCImportDecl GhcPs = EpAnn' EpAnnImportDecl +type instance XCImportDecl GhcPs = EpAnn EpAnnImportDecl type instance XCImportDecl GhcRn = NoExtField type instance XCImportDecl GhcTc = NoExtField @@ -127,12 +127,12 @@ type instance Anno [LocatedA (IE (GhcPass p))] = SrcSpanAnnL -- API Annotations types data EpAnnImportDecl = EpAnnImportDecl - { importDeclAnnImport :: EpaAnchor - , importDeclAnnPragma :: Maybe (EpaAnchor, EpaAnchor) - , importDeclAnnSafe :: Maybe EpaAnchor - , importDeclAnnQualified :: Maybe EpaAnchor - , importDeclAnnPackage :: Maybe EpaAnchor - , importDeclAnnAs :: Maybe EpaAnchor + { importDeclAnnImport :: EpaLocation + , importDeclAnnPragma :: Maybe (EpaLocation, EpaLocation) + , importDeclAnnSafe :: Maybe EpaLocation + , importDeclAnnQualified :: Maybe EpaLocation + , importDeclAnnPackage :: Maybe EpaLocation + , importDeclAnnAs :: Maybe EpaLocation } deriving (Data) -- --------------------------------------------------------------------- @@ -208,9 +208,9 @@ instance (OutputableBndrId p -- 'GHC.Parser.Annotation' is the location of the adornment in -- the original source. data IEWrappedName name - = IEName (LocatedN name) -- ^ no extra - | IEPattern EpaAnchor (LocatedN name) -- ^ pattern X - | IEType EpaAnchor (LocatedN name) -- ^ type (:+:) + = IEName (LocatedN name) -- ^ no extra + | IEPattern EpaLocation (LocatedN name) -- ^ pattern X + | IEType EpaLocation (LocatedN name) -- ^ type (:+:) deriving (Eq,Data) -- | Located name with possible adornment @@ -286,15 +286,15 @@ type instance XIEVar GhcPs = NoExtField type instance XIEVar GhcRn = NoExtField type instance XIEVar GhcTc = NoExtField -type instance XIEThingAbs (GhcPass _) = EpAnn -type instance XIEThingAll (GhcPass _) = EpAnn +type instance XIEThingAbs (GhcPass _) = EpAnn [AddEpAnn] +type instance XIEThingAll (GhcPass _) = EpAnn [AddEpAnn] -- See Note [IEThingWith] -type instance XIEThingWith (GhcPass 'Parsed) = EpAnn +type instance XIEThingWith (GhcPass 'Parsed) = EpAnn [AddEpAnn] type instance XIEThingWith (GhcPass 'Renamed) = [Located FieldLabel] type instance XIEThingWith (GhcPass 'Typechecked) = NoExtField -type instance XIEModuleContents GhcPs = EpAnn +type instance XIEModuleContents GhcPs = EpAnn [AddEpAnn] type instance XIEModuleContents GhcRn = NoExtField type instance XIEModuleContents GhcTc = NoExtField diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs index 6efbfb860e..577321ea0a 100644 --- a/compiler/GHC/Hs/Pat.hs +++ b/compiler/GHC/Hs/Pat.hs @@ -95,55 +95,55 @@ type instance XWildPat GhcTc = Type type instance XVarPat (GhcPass _) = NoExtField -type instance XLazyPat GhcPs = EpAnn -- For '~' +type instance XLazyPat GhcPs = EpAnn [AddEpAnn] -- For '~' type instance XLazyPat GhcRn = NoExtField type instance XLazyPat GhcTc = NoExtField -type instance XAsPat GhcPs = EpAnn -- For '@' +type instance XAsPat GhcPs = EpAnn [AddEpAnn] -- For '@' type instance XAsPat GhcRn = NoExtField type instance XAsPat GhcTc = NoExtField -type instance XParPat (GhcPass _) = EpAnn' AnnParen +type instance XParPat (GhcPass _) = EpAnn AnnParen -type instance XBangPat GhcPs = EpAnn -- For '!' +type instance XBangPat GhcPs = EpAnn [AddEpAnn] -- For '!' type instance XBangPat GhcRn = NoExtField type instance XBangPat GhcTc = NoExtField -- Note: XListPat cannot be extended when using GHC 8.0.2 as the bootstrap -- compiler, as it triggers https://gitlab.haskell.org/ghc/ghc/issues/14396 for -- `SyntaxExpr` -type instance XListPat GhcPs = EpAnn' AnnList +type instance XListPat GhcPs = EpAnn AnnList type instance XListPat GhcRn = Maybe (SyntaxExpr GhcRn) type instance XListPat GhcTc = ListPatTc -type instance XTuplePat GhcPs = EpAnn +type instance XTuplePat GhcPs = EpAnn [AddEpAnn] type instance XTuplePat GhcRn = NoExtField type instance XTuplePat GhcTc = [Type] -type instance XSumPat GhcPs = EpAnn' EpAnnSumPat +type instance XSumPat GhcPs = EpAnn EpAnnSumPat type instance XSumPat GhcRn = NoExtField type instance XSumPat GhcTc = [Type] -type instance XConPat GhcPs = EpAnn +type instance XConPat GhcPs = EpAnn [AddEpAnn] type instance XConPat GhcRn = NoExtField type instance XConPat GhcTc = ConPatTc -type instance XViewPat GhcPs = EpAnn +type instance XViewPat GhcPs = EpAnn [AddEpAnn] type instance XViewPat GhcRn = NoExtField type instance XViewPat GhcTc = Type type instance XSplicePat (GhcPass _) = NoExtField type instance XLitPat (GhcPass _) = NoExtField -type instance XNPat GhcPs = EpAnn -type instance XNPat GhcRn = EpAnn +type instance XNPat GhcPs = EpAnn [AddEpAnn] +type instance XNPat GhcRn = EpAnn [AddEpAnn] type instance XNPat GhcTc = Type -type instance XNPlusKPat GhcPs = EpAnn +type instance XNPlusKPat GhcPs = EpAnn [AddEpAnn] type instance XNPlusKPat GhcRn = NoExtField type instance XNPlusKPat GhcTc = Type -type instance XSigPat GhcPs = EpAnn +type instance XSigPat GhcPs = EpAnn [AddEpAnn] type instance XSigPat GhcRn = NoExtField type instance XSigPat GhcTc = Type @@ -156,7 +156,7 @@ type instance ConLikeP GhcPs = RdrName -- IdP GhcPs type instance ConLikeP GhcRn = Name -- IdP GhcRn type instance ConLikeP GhcTc = ConLike -type instance XHsRecField _ = EpAnn +type instance XHsRecField _ = EpAnn [AddEpAnn] -- --------------------------------------------------------------------- @@ -164,8 +164,8 @@ type instance XHsRecField _ = EpAnn data EpAnnSumPat = EpAnnSumPat { sumPatParens :: [AddEpAnn] - , sumPatVbarsBefore :: [EpaAnchor] - , sumPatVbarsAfter :: [EpaAnchor] + , sumPatVbarsBefore :: [EpaLocation] + , sumPatVbarsAfter :: [EpaLocation] } deriving Data -- --------------------------------------------------------------------- diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs index 9c494d6aa7..a666a87519 100644 --- a/compiler/GHC/Hs/Type.hs +++ b/compiler/GHC/Hs/Type.hs @@ -151,7 +151,7 @@ type instance XHsForAllInvis (GhcPass _) = EpAnnForallTy type instance XXHsForAllTelescope (GhcPass _) = NoExtCon -type EpAnnForallTy = EpAnn' (AddEpAnn, AddEpAnn) +type EpAnnForallTy = EpAnn (AddEpAnn, AddEpAnn) -- ^ Location of 'forall' and '->' for HsForAllVis -- Location of 'forall' and '.' for HsForAllInvis @@ -259,8 +259,8 @@ mkEmptyWildCardBndrs x = HsWC { hswc_body = x -------------------------------------------------- -type instance XUserTyVar (GhcPass _) = EpAnn -type instance XKindedTyVar (GhcPass _) = EpAnn +type instance XUserTyVar (GhcPass _) = EpAnn [AddEpAnn] +type instance XKindedTyVar (GhcPass _) = EpAnn [AddEpAnn] type instance XXTyVarBndr (GhcPass _) = NoExtCon @@ -285,17 +285,17 @@ instance NamedThing (HsTyVarBndr flag GhcRn) where type instance XForAllTy (GhcPass _) = NoExtField type instance XQualTy (GhcPass _) = NoExtField -type instance XTyVar (GhcPass _) = EpAnn +type instance XTyVar (GhcPass _) = EpAnn [AddEpAnn] type instance XAppTy (GhcPass _) = NoExtField -type instance XFunTy (GhcPass _) = EpAnn' TrailingAnn -- For the AnnRarrow or AnnLolly -type instance XListTy (GhcPass _) = EpAnn' AnnParen -type instance XTupleTy (GhcPass _) = EpAnn' AnnParen -type instance XSumTy (GhcPass _) = EpAnn' AnnParen +type instance XFunTy (GhcPass _) = EpAnn TrailingAnn -- For the AnnRarrow or AnnLolly +type instance XListTy (GhcPass _) = EpAnn AnnParen +type instance XTupleTy (GhcPass _) = EpAnn AnnParen +type instance XSumTy (GhcPass _) = EpAnn AnnParen type instance XOpTy (GhcPass _) = NoExtField -type instance XParTy (GhcPass _) = EpAnn' AnnParen -type instance XIParamTy (GhcPass _) = EpAnn +type instance XParTy (GhcPass _) = EpAnn AnnParen +type instance XIParamTy (GhcPass _) = EpAnn [AddEpAnn] type instance XStarTy (GhcPass _) = NoExtField -type instance XKindSig (GhcPass _) = EpAnn +type instance XKindSig (GhcPass _) = EpAnn [AddEpAnn] type instance XAppKindTy (GhcPass _) = SrcSpan -- Where the `@` lives @@ -303,18 +303,18 @@ type instance XSpliceTy GhcPs = NoExtField type instance XSpliceTy GhcRn = NoExtField type instance XSpliceTy GhcTc = Kind -type instance XDocTy (GhcPass _) = EpAnn -type instance XBangTy (GhcPass _) = EpAnn +type instance XDocTy (GhcPass _) = EpAnn [AddEpAnn] +type instance XBangTy (GhcPass _) = EpAnn [AddEpAnn] -type instance XRecTy GhcPs = EpAnn' AnnList +type instance XRecTy GhcPs = EpAnn AnnList type instance XRecTy GhcRn = NoExtField type instance XRecTy GhcTc = NoExtField -type instance XExplicitListTy GhcPs = EpAnn +type instance XExplicitListTy GhcPs = EpAnn [AddEpAnn] type instance XExplicitListTy GhcRn = NoExtField type instance XExplicitListTy GhcTc = Kind -type instance XExplicitTupleTy GhcPs = EpAnn +type instance XExplicitTupleTy GhcPs = EpAnn [AddEpAnn] type instance XExplicitTupleTy GhcRn = NoExtField type instance XExplicitTupleTy GhcTc = [Kind] @@ -354,7 +354,7 @@ pprHsArrow (HsUnrestrictedArrow _) = arrow pprHsArrow (HsLinearArrow _ _) = lollipop pprHsArrow (HsExplicitMult _ _ p) = (mulArrow (ppr p)) -type instance XConDeclField (GhcPass _) = EpAnn +type instance XConDeclField (GhcPass _) = EpAnn [AddEpAnn] type instance XXConDeclField (GhcPass _) = NoExtCon instance OutputableBndrId p @@ -494,7 +494,7 @@ splitHsFunType ty = go ty an' = addTrailingAnnToA l an cs a x' = L (SrcSpanAnn an' l) t - go other = ([], noCom, [], other) + go other = ([], emptyComments, [], other) -- | Retrieve the name of the \"head\" of a nested type application. -- This is somewhat like @GHC.Tc.Gen.HsType.splitHsAppTys@, but a little more diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index a23c1a1868..bf37398347 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -190,14 +190,14 @@ mkSimpleMatch ctxt pats rhs unguardedGRHSs :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpan - => SrcSpan -> LocatedA (body (GhcPass p)) -> EpAnn' GrhsAnn + => SrcSpan -> LocatedA (body (GhcPass p)) -> EpAnn GrhsAnn -> GRHSs (GhcPass p) (LocatedA (body (GhcPass p))) unguardedGRHSs loc rhs an = GRHSs noExtField (unguardedRHS an loc rhs) emptyLocalBinds unguardedRHS :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpan - => EpAnn' GrhsAnn -> SrcSpan -> LocatedA (body (GhcPass p)) + => EpAnn GrhsAnn -> SrcSpan -> LocatedA (body (GhcPass p)) -> [LGRHS (GhcPass p) (LocatedA (body (GhcPass p)))] unguardedRHS an loc rhs = [L loc (GRHS an [] rhs)] @@ -305,16 +305,16 @@ mkHsIntegral :: IntegralLit -> HsOverLit GhcPs mkHsFractional :: FractionalLit -> HsOverLit GhcPs mkHsIsString :: SourceText -> FastString -> HsOverLit GhcPs mkHsDo :: HsStmtContext GhcRn -> LocatedL [ExprLStmt GhcPs] -> HsExpr GhcPs -mkHsDoAnns :: HsStmtContext GhcRn -> LocatedL [ExprLStmt GhcPs] -> EpAnn' AnnList -> HsExpr GhcPs +mkHsDoAnns :: HsStmtContext GhcRn -> LocatedL [ExprLStmt GhcPs] -> EpAnn AnnList -> HsExpr GhcPs mkHsComp :: HsStmtContext GhcRn -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> HsExpr GhcPs mkHsCompAnns :: HsStmtContext GhcRn -> [ExprLStmt GhcPs] -> LHsExpr GhcPs - -> EpAnn' AnnList + -> EpAnn AnnList -> HsExpr GhcPs -mkNPat :: Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> EpAnn +mkNPat :: Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> EpAnn [AddEpAnn] -> Pat GhcPs -mkNPlusKPat :: LocatedN RdrName -> Located (HsOverLit GhcPs) -> EpAnn +mkNPlusKPat :: LocatedN RdrName -> Located (HsOverLit GhcPs) -> EpAnn [AddEpAnn] -> Pat GhcPs -- NB: The following functions all use noSyntaxExpr: the generated expressions @@ -323,7 +323,7 @@ mkLastStmt :: IsPass idR => LocatedA (bodyR (GhcPass idR)) -> StmtLR (GhcPass idL) (GhcPass idR) (LocatedA (bodyR (GhcPass idR))) mkBodyStmt :: LocatedA (bodyR GhcPs) -> StmtLR (GhcPass idL) GhcPs (LocatedA (bodyR GhcPs)) -mkPsBindStmt :: EpAnn -> LPat GhcPs -> LocatedA (bodyR GhcPs) +mkPsBindStmt :: EpAnn [AddEpAnn] -> LPat GhcPs -> LocatedA (bodyR GhcPs) -> StmtLR GhcPs GhcPs (LocatedA (bodyR GhcPs)) mkRnBindStmt :: LPat GhcRn -> LocatedA (bodyR GhcRn) -> StmtLR GhcRn GhcRn (LocatedA (bodyR GhcRn)) @@ -345,7 +345,7 @@ mkRecStmt :: (Anno [GenLocated (Anno (StmtLR (GhcPass idL) GhcPs bodyR)) (StmtLR (GhcPass idL) GhcPs bodyR)] ~ SrcSpanAnnL) - => EpAnn' AnnList + => EpAnn AnnList -> LocatedL [LStmtLR (GhcPass idL) GhcPs bodyR] -> StmtLR (GhcPass idL) GhcPs bodyR @@ -363,12 +363,12 @@ mkHsCompAnns ctxt stmts expr anns = mkHsDoAnns ctxt (mkLocatedList (stmts ++ [la last_stmt = L (noAnnSrcSpan $ getLocA expr) $ mkLastStmt expr -- restricted to GhcPs because other phases might need a SyntaxExpr -mkHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> EpAnn +mkHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> EpAnn [AddEpAnn] -> HsExpr GhcPs mkHsIf c a b anns = HsIf anns c a b -- restricted to GhcPs because other phases might need a SyntaxExpr -mkHsCmdIf :: LHsExpr GhcPs -> LHsCmd GhcPs -> LHsCmd GhcPs -> EpAnn +mkHsCmdIf :: LHsExpr GhcPs -> LHsCmd GhcPs -> LHsCmd GhcPs -> EpAnn [AddEpAnn] -> HsCmd GhcPs mkHsCmdIf c a b anns = HsCmdIf anns noSyntaxExpr c a b @@ -376,17 +376,17 @@ mkNPat lit neg anns = NPat anns lit neg noSyntaxExpr mkNPlusKPat id lit anns = NPlusKPat anns id lit (unLoc lit) noSyntaxExpr noSyntaxExpr -mkTransformStmt :: EpAnn -> [ExprLStmt GhcPs] -> LHsExpr GhcPs +mkTransformStmt :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) -mkTransformByStmt :: EpAnn -> [ExprLStmt GhcPs] -> LHsExpr GhcPs +mkTransformByStmt :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) -mkGroupUsingStmt :: EpAnn -> [ExprLStmt GhcPs] -> LHsExpr GhcPs +mkGroupUsingStmt :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) -mkGroupByUsingStmt :: EpAnn -> [ExprLStmt GhcPs] -> LHsExpr GhcPs +mkGroupByUsingStmt :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) -emptyTransStmt :: EpAnn -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) +emptyTransStmt :: EpAnn [AddEpAnn] -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) emptyTransStmt anns = TransStmt { trS_ext = anns , trS_form = panic "emptyTransStmt: form" , trS_stmts = [], trS_bndrs = [] @@ -436,7 +436,7 @@ emptyRecStmtId = emptyRecStmt' unitRecStmtTc -- a panic might trigger during zonking mkRecStmt anns stmts = (emptyRecStmt' anns) { recS_stmts = stmts } -mkLetStmt :: EpAnn -> HsLocalBinds GhcPs -> StmtLR GhcPs GhcPs (LocatedA b) +mkLetStmt :: EpAnn [AddEpAnn] -> HsLocalBinds GhcPs -> StmtLR GhcPs GhcPs (LocatedA b) mkLetStmt anns binds = LetStmt anns binds ------------------------------- @@ -448,10 +448,10 @@ mkHsOpApp e1 op e2 = OpApp noAnn e1 (noLocA (HsVar noExtField (noLocA op))) e2 unqualSplice :: RdrName unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice")) -mkUntypedSplice :: EpAnn -> SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs +mkUntypedSplice :: EpAnn [AddEpAnn] -> SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs mkUntypedSplice ann hasParen e = HsUntypedSplice ann hasParen unqualSplice e -mkTypedSplice :: EpAnn -> SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs +mkTypedSplice :: EpAnn [AddEpAnn] -> SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs mkTypedSplice ann hasParen e = HsTypedSplice ann hasParen unqualSplice e mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice GhcPs @@ -657,7 +657,7 @@ mkLHsVarTuple ids ext = mkLHsTupleExpr (map nlHsVar ids) ext nlTuplePat :: [LPat GhcPs] -> Boxity -> LPat GhcPs nlTuplePat pats box = noLocA (TuplePat noAnn pats box) -missingTupArg :: EpAnn' EpaAnchor -> HsTupArg GhcPs +missingTupArg :: EpAnn EpaLocation -> HsTupArg GhcPs missingTupArg ann = Missing ann mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn @@ -862,7 +862,7 @@ mkVarBind var rhs = L (getLoc rhs) $ var_id = var, var_rhs = rhs } mkPatSynBind :: LocatedN RdrName -> HsPatSynDetails GhcPs - -> LPat GhcPs -> HsPatSynDir GhcPs -> EpAnn -> HsBind GhcPs + -> LPat GhcPs -> HsPatSynDir GhcPs -> EpAnn [AddEpAnn] -> HsBind GhcPs mkPatSynBind name details lpat dir anns = PatSynBind noExtField psb where psb = PSB{ psb_ext = anns diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs index ba7cd74a89..10eee59112 100644 --- a/compiler/GHC/HsToCore/Foreign/Decl.hs +++ b/compiler/GHC/HsToCore/Foreign/Decl.hs @@ -23,6 +23,7 @@ import GHC.Core import GHC.HsToCore.Foreign.Call import GHC.HsToCore.Monad +import GHC.HsToCore.Types (ds_next_wrapper_num) import GHC.Hs import GHC.Core.DataCon @@ -229,12 +230,12 @@ dsFCall fn_id co fcall mDeclHeader = do ccall_uniq <- newUnique work_uniq <- newUnique - dflags <- getDynFlags (fcall', cDoc) <- case fcall of CCall (CCallSpec (StaticTarget _ cName mUnitId isFun) CApiConv safety) -> - do wrapperName <- mkWrapperName "ghc_wrapper" (unpackFS cName) + do nextWrapperNum <- ds_next_wrapper_num <$> getGblEnv + wrapperName <- mkWrapperName nextWrapperNum "ghc_wrapper" (unpackFS cName) let fcall' = CCall (CCallSpec (StaticTarget NoSourceText wrapperName mUnitId @@ -278,6 +279,7 @@ dsFCall fn_id co fcall mDeclHeader = do return (fcall', c) _ -> return (fcall, empty) + dflags <- getDynFlags let -- Build the worker worker_ty = mkForAllTys tv_bndrs (mkVisFunTysMany (map idType work_arg_ids) ccall_result_ty) diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs index a16f70cded..788f4828e2 100644 --- a/compiler/GHC/HsToCore/Monad.hs +++ b/compiler/GHC/HsToCore/Monad.hs @@ -236,8 +236,10 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env complete_matches = hptCompleteSigs hsc_env -- from the home package ++ tcg_complete_matches tcg_env -- from the current module ++ eps_complete_matches eps -- from imports + -- re-use existing next_wrapper_num to ensure uniqueness + next_wrapper_num_var = tcg_next_wrapper_num tcg_env ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env - msg_var cc_st_var complete_matches + msg_var cc_st_var next_wrapper_num_var complete_matches } runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages DiagnosticMessage, Maybe a) @@ -261,6 +263,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds , mg_complete_matches = local_complete_matches }) thing_inside = do { cc_st_var <- newIORef newCostCentreState + ; next_wrapper_num <- newIORef emptyModuleEnv ; msg_var <- newIORef emptyMessages ; eps <- liftIO $ hscEPS hsc_env ; let unit_env = hsc_unit_env hsc_env @@ -275,7 +278,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds envs = mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env msg_var cc_st_var - complete_matches + next_wrapper_num complete_matches ; runDs hsc_env envs thing_inside } @@ -313,10 +316,11 @@ initTcDsForSolver thing_inside Nothing -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLoc (getErrorMessages msgs)) } mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv - -> IORef (Messages DiagnosticMessage) -> IORef CostCentreState -> CompleteMatches + -> IORef (Messages DiagnosticMessage) -> IORef CostCentreState + -> IORef (ModuleEnv Int) -> CompleteMatches -> (DsGblEnv, DsLclEnv) mkDsEnvs unit_env mod rdr_env type_env fam_inst_env msg_var cc_st_var - complete_matches + next_wrapper_num complete_matches = let if_genv = IfGblEnv { if_doc = text "mkDsEnvs", if_rec_types = Just (mod, return type_env) } if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod) @@ -330,6 +334,7 @@ mkDsEnvs unit_env mod rdr_env type_env fam_inst_env msg_var cc_st_var , ds_msgs = msg_var , ds_complete_matches = complete_matches , ds_cc_st = cc_st_var + , ds_next_wrapper_num = next_wrapper_num } lcl_env = DsLclEnv { dsl_meta = emptyNameEnv , dsl_loc = real_span diff --git a/compiler/GHC/HsToCore/Types.hs b/compiler/GHC/HsToCore/Types.hs index aa3e097c0d..58273e250e 100644 --- a/compiler/GHC/HsToCore/Types.hs +++ b/compiler/GHC/HsToCore/Types.hs @@ -6,6 +6,8 @@ module GHC.HsToCore.Types ( DsMetaEnv, DsMetaVal(..), CompleteMatches ) where +import GHC.Prelude (Int) + import Data.IORef import GHC.Types.CostCentre.State @@ -54,6 +56,8 @@ data DsGblEnv -- Additional complete pattern matches , ds_cc_st :: IORef CostCentreState -- Tracking indices for cost centre annotations + , ds_next_wrapper_num :: IORef (ModuleEnv Int) + -- ^ See Note [Generating fresh names for FFI wrappers] } instance ContainsModule DsGblEnv where diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs index c6175b2602..e9e69f5c68 100644 --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -1254,7 +1254,7 @@ tidyTopIdInfo uf_opts rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold -- the function returns bottom -- In this case, show_unfold will be false (we don't expose unfoldings -- for bottoming functions), but we might still have a worker/wrapper - -- split (see Note [Worker-wrapper for bottoming functions] in + -- split (see Note [Worker/wrapper for bottoming functions] in -- GHC.Core.Opt.WorkWrap) diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index 356a728b23..6c85b8d08c 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -1112,27 +1112,27 @@ importdecl :: { LImportDecl GhcPs } } -maybe_src :: { ((Maybe (EpaAnchor,EpaAnchor),SourceText),IsBootInterface) } +maybe_src :: { ((Maybe (EpaLocation,EpaLocation),SourceText),IsBootInterface) } : '{-# SOURCE' '#-}' { ((Just (glAA $1,glAA $2),getSOURCE_PRAGs $1) , IsBoot) } | {- empty -} { ((Nothing,NoSourceText),NotBoot) } -maybe_safe :: { (Maybe EpaAnchor,Bool) } +maybe_safe :: { (Maybe EpaLocation,Bool) } : 'safe' { (Just (glAA $1),True) } | {- empty -} { (Nothing, False) } -maybe_pkg :: { (Maybe EpaAnchor,Maybe StringLiteral) } +maybe_pkg :: { (Maybe EpaLocation,Maybe StringLiteral) } : STRING {% do { let { pkgFS = getSTRING $1 } ; unless (looksLikePackageName (unpackFS pkgFS)) $ addError $ PsError (PsErrInvalidPackageName pkgFS) [] (getLoc $1) ; return (Just (glAA $1), Just (StringLiteral (getSTRINGs $1) pkgFS Nothing)) } } | {- empty -} { (Nothing,Nothing) } -optqualified :: { Located (Maybe EpaAnchor) } +optqualified :: { Located (Maybe EpaLocation) } : 'qualified' { sL1 $1 (Just (glAA $1)) } | {- empty -} { noLoc Nothing } -maybeas :: { (Maybe EpaAnchor,Located (Maybe (Located ModuleName))) } +maybeas :: { (Maybe EpaLocation,Located (Maybe (Located ModuleName))) } : 'as' modid { (Just (glAA $1) ,sLL $1 $> (Just $2)) } | {- empty -} { (Nothing,noLoc Nothing) } @@ -1545,7 +1545,7 @@ datafam_inst_hdr :: { Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs >>= \tvbs -> (acs (\cs -> (sLL $1 (reLoc $>) (Just ( addTrailingDarrowC $4 $5 cs) - , mkHsOuterExplicit (EpAnn (glR $1) (mu AnnForall $1, mj AnnDot $3) noCom) tvbs, $6)))) + , mkHsOuterExplicit (EpAnn (glR $1) (mu AnnForall $1, mj AnnDot $3) emptyComments) tvbs, $6)))) } | 'forall' tv_bndrs '.' type {% do { hintExplicitForall $1 ; tvbs <- fromSpecTyVarBndrs $2 @@ -2007,7 +2007,7 @@ annotation :: { LHsDecl GhcPs } ----------------------------------------------------------------------------- -- Foreign import and export declarations -fdecl :: { Located ([AddEpAnn],EpAnn -> HsDecl GhcPs) } +fdecl :: { Located ([AddEpAnn],EpAnn [AddEpAnn] -> HsDecl GhcPs) } fdecl : 'import' callconv safety fspec {% mkImport $2 $3 (snd $ unLoc $4) >>= \i -> return (sLL $1 $> (mj AnnImport $1 : (fst $ unLoc $4),i)) } @@ -2787,7 +2787,7 @@ aexp :: { ECP } $ Match { m_ext = EpAnn (glR $1) [mj AnnLam $1] cs , m_ctxt = LambdaExpr , m_pats = $2:$3 - , m_grhss = unguardedGRHSs (comb2 $4 (reLoc $5)) $5 (EpAnn (glR $4) (GrhsAnn Nothing (mu AnnRarrow $4)) noCom) }])) } + , m_grhss = unguardedGRHSs (comb2 $4 (reLoc $5)) $5 (EpAnn (glR $4) (GrhsAnn Nothing (mu AnnRarrow $4)) emptyComments) }])) } | 'let' binds 'in' exp { ECP $ unECP $4 >>= \ $4 -> mkHsLetPV (comb2A $1 $>) (unLoc $2) $4 @@ -2852,7 +2852,7 @@ aexp1 :: { ECP } | aexp1 TIGHT_INFIX_PROJ field {% runPV (unECP $1) >>= \ $1 -> fmap ecpFromExp $ acsa (\cs -> - let fl = sLL $2 $> (HsFieldLabel ((EpAnn (glR $2) (AnnFieldLabel (Just $ glAA $2)) noCom)) $3) in + let fl = sLL $2 $> (HsFieldLabel ((EpAnn (glR $2) (AnnFieldLabel (Just $ glAA $2)) emptyComments)) $3) in mkRdrGetField (noAnnSrcSpan $ comb2 (reLoc $1) $>) $1 fl (EpAnn (glAR $1) NoEpAnns cs)) } @@ -3020,11 +3020,11 @@ tup_exprs :: { forall b. DisambECP b => PV (SumOrTuple b) } : texp commas_tup_tail { unECP $1 >>= \ $1 -> $2 >>= \ $2 -> - do { t <- amsA $1 [AddCommaAnn (AR $ rs $ fst $2)] + do { t <- amsA $1 [AddCommaAnn (EpaSpan $ rs $ fst $2)] ; return (Tuple (Right t : snd $2)) } } | commas tup_tail { $2 >>= \ $2 -> - do { let {cos = map (\ll -> (Left (EpAnn (anc $ rs ll) (AR $ rs ll) noCom))) (fst $1) } + do { let {cos = map (\ll -> (Left (EpAnn (anc $ rs ll) (EpaSpan $ rs ll) emptyComments))) (fst $1) } ; return (Tuple (cos ++ $2)) } } | texp bars { unECP $1 >>= \ $1 -> return $ @@ -3035,17 +3035,17 @@ tup_exprs :: { forall b. DisambECP b => PV (SumOrTuple b) } (Sum (snd $1 + 1) (snd $1 + snd $3 + 1) $2 (fst $1) (fst $3)) } -- Always starts with commas; always follows an expr -commas_tup_tail :: { forall b. DisambECP b => PV (SrcSpan,[Either (EpAnn' EpaAnchor) (LocatedA b)]) } +commas_tup_tail :: { forall b. DisambECP b => PV (SrcSpan,[Either (EpAnn EpaLocation) (LocatedA b)]) } commas_tup_tail : commas tup_tail { $2 >>= \ $2 -> - do { let {cos = map (\l -> (Left (EpAnn (anc $ rs l) (AR $ rs l) noCom))) (tail $ fst $1) } + do { let {cos = map (\l -> (Left (EpAnn (anc $ rs l) (EpaSpan $ rs l) emptyComments))) (tail $ fst $1) } ; return ((head $ fst $1, cos ++ $2)) } } -- Always follows a comma -tup_tail :: { forall b. DisambECP b => PV [Either (EpAnn' EpaAnchor) (LocatedA b)] } +tup_tail :: { forall b. DisambECP b => PV [Either (EpAnn EpaLocation) (LocatedA b)] } : texp commas_tup_tail { unECP $1 >>= \ $1 -> $2 >>= \ $2 -> - do { t <- amsA $1 [AddCommaAnn (AR $ rs $ fst $2)] + do { t <- amsA $1 [AddCommaAnn (EpaSpan $ rs $ fst $2)] ; return (Right t : snd $2) } } | texp { unECP $1 >>= \ $1 -> return [Right $1] } @@ -3382,7 +3382,7 @@ fbind :: { forall b. DisambECP b => PV (Fbind b) } let top = sL1 $1 $ HsFieldLabel noAnn $1 ((L lf (HsFieldLabel _ f)):t) = reverse (unLoc $3) lf' = comb2 $2 (L lf ()) - fields = top : L lf' (HsFieldLabel (EpAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA $2)) noCom) f) : t + fields = top : L lf' (HsFieldLabel (EpAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA $2)) emptyComments) f) : t final = last fields l = comb2 $1 $3 isPun = False @@ -3398,7 +3398,7 @@ fbind :: { forall b. DisambECP b => PV (Fbind b) } let top = sL1 $1 $ HsFieldLabel noAnn $1 ((L lf (HsFieldLabel _ f)):t) = reverse (unLoc $3) lf' = comb2 $2 (L lf ()) - fields = top : L lf' (HsFieldLabel (EpAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA $2)) noCom) f) : t + fields = top : L lf' (HsFieldLabel (EpAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA $2)) emptyComments) f) : t final = last fields l = comb2 $1 $3 isPun = True @@ -3514,10 +3514,10 @@ con_list : con { sL1N $1 [$1] } sysdcon_nolist :: { LocatedN DataCon } -- Wired in data constructors : '(' ')' {% amsrn (sLL $1 $> unitDataCon) (NameAnnOnly NameParens (glAA $1) (glAA $2) []) } | '(' commas ')' {% amsrn (sLL $1 $> $ tupleDataCon Boxed (snd $2 + 1)) - (NameAnnCommas NameParens (glAA $1) (map (AR . realSrcSpan) (fst $2)) (glAA $3) []) } + (NameAnnCommas NameParens (glAA $1) (map (EpaSpan . realSrcSpan) (fst $2)) (glAA $3) []) } | '(#' '#)' {% amsrn (sLL $1 $> $ unboxedUnitDataCon) (NameAnnOnly NameParensHash (glAA $1) (glAA $2) []) } | '(#' commas '#)' {% amsrn (sLL $1 $> $ tupleDataCon Unboxed (snd $2 + 1)) - (NameAnnCommas NameParensHash (glAA $1) (map (AR . realSrcSpan) (fst $2)) (glAA $3) []) } + (NameAnnCommas NameParensHash (glAA $1) (map (EpaSpan . realSrcSpan) (fst $2)) (glAA $3) []) } -- See Note [Empty lists] in GHC.Hs.Expr sysdcon :: { LocatedN DataCon } @@ -3551,10 +3551,10 @@ ntgtycon :: { LocatedN RdrName } -- A "general" qualified tycon, excluding unit : oqtycon { $1 } | '(' commas ')' {% amsrn (sLL $1 $> $ getRdrName (tupleTyCon Boxed (snd $2 + 1))) - (NameAnnCommas NameParens (glAA $1) (map (AR . realSrcSpan) (fst $2)) (glAA $3) []) } + (NameAnnCommas NameParens (glAA $1) (map (EpaSpan . realSrcSpan) (fst $2)) (glAA $3) []) } | '(#' commas '#)' {% amsrn (sLL $1 $> $ getRdrName (tupleTyCon Unboxed (snd $2 + 1))) - (NameAnnCommas NameParensHash (glAA $1) (map (AR . realSrcSpan) (fst $2)) (glAA $3) []) } + (NameAnnCommas NameParensHash (glAA $1) (map (EpaSpan . realSrcSpan) (fst $2)) (glAA $3) []) } | '(' '->' ')' {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon) (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) } | '[' ']' {% amsrn (sLL $1 $> $ listTyCon_RDR) @@ -3846,11 +3846,11 @@ commas :: { ([SrcSpan],Int) } -- One or more commas : commas ',' { ((fst $1)++[gl $2],snd $1 + 1) } | ',' { ([gl $1],1) } -bars0 :: { ([EpaAnchor],Int) } -- Zero or more bars +bars0 :: { ([EpaLocation],Int) } -- Zero or more bars : bars { $1 } | { ([], 0) } -bars :: { ([EpaAnchor],Int) } -- One or more bars +bars :: { ([EpaLocation],Int) } -- One or more bars : bars '|' { ((fst $1)++[glAA $2],snd $1 + 1) } | '|' { ([glAA $1],1) } @@ -4148,28 +4148,28 @@ in GHC.Parser.Annotation -- |Construct an AddEpAnn from the annotation keyword and the location -- of the keyword itself mj :: AnnKeywordId -> Located e -> AddEpAnn -mj a l = AddEpAnn a (AR $ rs $ gl l) +mj a l = AddEpAnn a (EpaSpan $ rs $ gl l) mjN :: AnnKeywordId -> LocatedN e -> AddEpAnn -mjN a l = AddEpAnn a (AR $ rs $ glN l) +mjN a l = AddEpAnn a (EpaSpan $ rs $ glN l) -- |Construct an AddEpAnn from the annotation keyword and the location -- of the keyword itself, provided the span is not zero width mz :: AnnKeywordId -> Located e -> [AddEpAnn] -mz a l = if isZeroWidthSpan (gl l) then [] else [AddEpAnn a (AR $ rs $ gl l)] +mz a l = if isZeroWidthSpan (gl l) then [] else [AddEpAnn a (EpaSpan $ rs $ gl l)] msemi :: Located e -> [TrailingAnn] -msemi l = if isZeroWidthSpan (gl l) then [] else [AddSemiAnn (AR $ rs $ gl l)] +msemi l = if isZeroWidthSpan (gl l) then [] else [AddSemiAnn (EpaSpan $ rs $ gl l)] -- |Construct an AddEpAnn from the annotation keyword and the Located Token. If -- the token has a unicode equivalent and this has been used, provide the -- unicode variant of the annotation. mu :: AnnKeywordId -> Located Token -> AddEpAnn -mu a lt@(L l t) = AddEpAnn (toUnicodeAnn a lt) (AR $ rs l) +mu a lt@(L l t) = AddEpAnn (toUnicodeAnn a lt) (EpaSpan $ rs l) mau :: Located Token -> TrailingAnn -mau lt@(L l t) = if isUnicode lt then AddRarrowAnnU (AR $ rs l) - else AddRarrowAnn (AR $ rs l) +mau lt@(L l t) = if isUnicode lt then AddRarrowAnnU (EpaSpan $ rs l) + else AddRarrowAnn (EpaSpan $ rs l) -- | If the 'Token' is using its unicode variant return the unicode variant of -- the annotation @@ -4191,8 +4191,8 @@ glN = getLocA glR :: Located a -> Anchor glR la = Anchor (realSrcSpan $ getLoc la) UnchangedAnchor -glAA :: Located a -> EpaAnchor -glAA = AR <$> realSrcSpan . getLoc +glAA :: Located a -> EpaLocation +glAA = EpaSpan <$> realSrcSpan . getLoc glRR :: Located a -> RealSrcSpan glRR = realSrcSpan . getLoc @@ -4203,22 +4203,22 @@ glAR la = Anchor (realSrcSpan $ getLocA la) UnchangedAnchor glNR :: LocatedN a -> Anchor glNR ln = Anchor (realSrcSpan $ getLocA ln) UnchangedAnchor -glNRR :: LocatedN a -> EpaAnchor -glNRR = AR <$> realSrcSpan . getLocA +glNRR :: LocatedN a -> EpaLocation +glNRR = EpaSpan <$> realSrcSpan . getLocA anc :: RealSrcSpan -> Anchor anc r = Anchor r UnchangedAnchor acs :: MonadP m => (EpAnnComments -> Located a) -> m (Located a) acs a = do - let (L l _) = a noCom + let (L l _) = a emptyComments cs <- getCommentsFor l return (a cs) -- Called at the very end to pick up the EOF position, as well as any comments not allocated yet. acsFinal :: (EpAnnComments -> Located a) -> P (Located a) acsFinal a = do - let (L l _) = a noCom + let (L l _) = a emptyComments cs <- getCommentsFor l csf <- getFinalCommentsFor l meof <- getEofPos @@ -4229,7 +4229,7 @@ acsFinal a = do acsa :: MonadP m => (EpAnnComments -> LocatedAn t a) -> m (LocatedAn t a) acsa a = do - let (L l _) = a noCom + let (L l _) = a emptyComments cs <- getCommentsFor (locA l) return (a cs) @@ -4311,7 +4311,7 @@ pvL a = do { av <- a parseModule :: P (Located HsModule) parseModule = parseModuleNoHaddock >>= addHaddockToModule -commentsA :: (Monoid ann) => SrcSpan -> EpAnnComments -> SrcSpanAnn' (EpAnn' ann) +commentsA :: (Monoid ann) => SrcSpan -> EpAnnComments -> SrcSpanAnn' (EpAnn ann) commentsA loc cs = SrcSpanAnn (EpAnn (Anchor (rs loc) UnchangedAnchor) mempty cs) loc -- | Instead of getting the *enclosed* comments, this includes the @@ -4328,7 +4328,7 @@ rs _ = panic "Parser should only have RealSrcSpan" hsDoAnn :: Located a -> LocatedAn t b -> AnnKeywordId -> AnnList hsDoAnn (L l _) (L ll _) kw - = AnnList (Just $ spanAsAnchor (locA ll)) Nothing Nothing [AddEpAnn kw (AR $ rs l)] [] + = AnnList (Just $ spanAsAnchor (locA ll)) Nothing Nothing [AddEpAnn kw (EpaSpan $ rs l)] [] listAsAnchor :: [LocatedAn t a] -> Anchor listAsAnchor [] = spanAsAnchor noSrcSpan @@ -4349,24 +4349,24 @@ addTrailingSemiA la span = addTrailingAnnA la span AddSemiAnn addTrailingCommaA :: MonadP m => LocatedA a -> SrcSpan -> m (LocatedA a) addTrailingCommaA la span = addTrailingAnnA la span AddCommaAnn -addTrailingAnnA :: MonadP m => LocatedA a -> SrcSpan -> (EpaAnchor -> TrailingAnn) -> m (LocatedA a) +addTrailingAnnA :: MonadP m => LocatedA a -> SrcSpan -> (EpaLocation -> TrailingAnn) -> m (LocatedA a) addTrailingAnnA (L (SrcSpanAnn anns l) a) ss ta = do -- cs <- getCommentsFor l - let cs = noCom + let cs = emptyComments -- AZ:TODO: generalise updating comments into an annotation let anns' = if isZeroWidthSpan ss then anns - else addTrailingAnnToA l (ta (AR $ rs ss)) cs anns + else addTrailingAnnToA l (ta (EpaSpan $ rs ss)) cs anns return (L (SrcSpanAnn anns' l) a) -- ------------------------------------- addTrailingVbarL :: MonadP m => LocatedL a -> SrcSpan -> m (LocatedL a) -addTrailingVbarL la span = addTrailingAnnL la (AddVbarAnn (AR $ rs span)) +addTrailingVbarL la span = addTrailingAnnL la (AddVbarAnn (EpaSpan $ rs span)) addTrailingCommaL :: MonadP m => LocatedL a -> SrcSpan -> m (LocatedL a) -addTrailingCommaL la span = addTrailingAnnL la (AddCommaAnn (AR $ rs span)) +addTrailingCommaL la span = addTrailingAnnL la (AddCommaAnn (EpaSpan $ rs span)) addTrailingAnnL :: MonadP m => LocatedL a -> TrailingAnn -> m (LocatedL a) addTrailingAnnL (L (SrcSpanAnn anns l) a) ta = do @@ -4380,15 +4380,15 @@ addTrailingAnnL (L (SrcSpanAnn anns l) a) ta = do addTrailingCommaN :: MonadP m => LocatedN a -> SrcSpan -> m (LocatedN a) addTrailingCommaN (L (SrcSpanAnn anns l) a) span = do -- cs <- getCommentsFor l - let cs = noCom + let cs = emptyComments -- AZ:TODO: generalise updating comments into an annotation let anns' = if isZeroWidthSpan span then anns - else addTrailingCommaToN l anns (AR $ rs span) + else addTrailingCommaToN l anns (EpaSpan $ rs span) return (L (SrcSpanAnn anns' l) a) -addTrailingCommaS :: Located StringLiteral -> EpaAnchor -> Located StringLiteral -addTrailingCommaS (L l sl) span = L l (sl { sl_tc = Just (epaAnchorRealSrcSpan span) }) +addTrailingCommaS :: Located StringLiteral -> EpaLocation -> Located StringLiteral +addTrailingCommaS (L l sl) span = L l (sl { sl_tc = Just (epaLocationRealSrcSpan span) }) -- ------------------------------------- diff --git a/compiler/GHC/Parser/Annotation.hs b/compiler/GHC/Parser/Annotation.hs index c62bdce65e..f234c7c789 100644 --- a/compiler/GHC/Parser/Annotation.hs +++ b/compiler/GHC/Parser/Annotation.hs @@ -13,16 +13,16 @@ module GHC.Parser.Annotation ( -- * In-tree Exact Print Annotations AddEpAnn(..), - EpaAnchor(..), epaAnchorRealSrcSpan, - DeltaPos(..), + EpaLocation(..), epaLocationRealSrcSpan, + DeltaPos(..), deltaPos, getDeltaLine, - EpAnn, EpAnn'(..), Anchor(..), AnchorOperation(..), + EpAnn(..), Anchor(..), AnchorOperation(..), spanAsAnchor, realSpanAsAnchor, noAnn, -- ** Comments in Annotations - EpAnnComments(..), LEpaComment, com, noCom, + EpAnnComments(..), LEpaComment, emptyComments, getFollowingComments, setFollowingComments, setPriorComments, EpAnnCO, @@ -316,8 +316,11 @@ data EpaComment = EpaComment { ac_tok :: EpaCommentTok , ac_prior_tok :: RealSrcSpan - -- ^ The location of the prior - -- token, used for exact printing + -- ^ The location of the prior token, used in exact printing. The + -- 'EpaComment' appears as an 'LEpaComment' containing its + -- location. The difference between the end of the prior token + -- and the start of this location is used for the spacing when + -- exact printing the comment. } deriving (Eq, Ord, Data, Show) @@ -332,6 +335,11 @@ data EpaCommentTok = | EpaBlockComment String -- ^ comment in {- -} | EpaEofComment -- ^ empty comment, capturing -- location of EOF + + -- See #19697 for a discussion of its use and how it should be + -- removed in favour of capturing it in the location for + -- 'Located HsModule' in the parser. + deriving (Eq, Ord, Data, Show) -- Note: these are based on the Token versions, but the Token type is -- defined in GHC.Parser.Lexer and bringing it in here would create a loop @@ -383,24 +391,24 @@ data HasE = HasE | NoE -- --------------------------------------------------------------------- -- | Captures an annotation, storing the @'AnnKeywordId'@ and its --- location. The parser only ever inserts @'EpaAnchor'@ fields with a +-- location. The parser only ever inserts @'EpaLocation'@ fields with a -- RealSrcSpan being the original location of the annotation in the -- source file. --- The @'EpaAnchor'@ can also store a delta position if the AST has been +-- The @'EpaLocation'@ can also store a delta position if the AST has been -- modified and needs to be pretty printed again. -- The usual way an 'AddEpAnn' is created is using the 'mj' ("make -- jump") function, and then it can be inserted into the appropriate -- annotation. -data AddEpAnn = AddEpAnn AnnKeywordId EpaAnchor deriving (Data,Show,Eq,Ord) +data AddEpAnn = AddEpAnn AnnKeywordId EpaLocation deriving (Data,Show,Eq,Ord) --- | The anchor for an @'AnnKeywordId'@. The Parser inserts the @'AR'@ +-- | The anchor for an @'AnnKeywordId'@. The Parser inserts the @'EpaSpan'@ -- variant, giving the exact location of the original item in the --- parsed source. This can be replace by the @'AD'@ version, to +-- parsed source. This can be replaced by the @'EpaDelta'@ version, to -- provide a position for the item relative to the end of the previous -- item in the source. This is useful when editing an AST prior to -- exact printing the changed one. -data EpaAnchor = AR RealSrcSpan - | AD DeltaPos +data EpaLocation = EpaSpan RealSrcSpan + | EpaDelta DeltaPos deriving (Data,Show,Eq,Ord) -- | Relative position, line then column. If 'deltaLine' is zero then @@ -409,20 +417,32 @@ data EpaAnchor = AR RealSrcSpan -- to, on the same line. If 'deltaLine' is > 0, then it is the number -- of lines to advance, and 'deltaColumn' is the start column on the -- new line. -data DeltaPos = - DP - { deltaLine :: !Int, - deltaColumn :: !Int - } deriving (Show,Eq,Ord,Data) - - -epaAnchorRealSrcSpan :: EpaAnchor -> RealSrcSpan -epaAnchorRealSrcSpan (AR r) = r -epaAnchorRealSrcSpan (AD _) = placeholderRealSpan - -instance Outputable EpaAnchor where - ppr (AR r) = text "AR" <+> ppr r - ppr (AD d) = text "AD" <+> ppr d +data DeltaPos + = SameLine { deltaColumn :: !Int } + | DifferentLine + { deltaLine :: !Int, -- ^ deltaLine should always be > 0 + deltaColumn :: !Int + } deriving (Show,Eq,Ord,Data) + +deltaPos :: Int -> Int -> DeltaPos +deltaPos l c = case l of + 0 -> SameLine c + _ -> DifferentLine l c + +getDeltaLine :: DeltaPos -> Int +getDeltaLine (SameLine _) = 0 +getDeltaLine (DifferentLine r _) = r + +-- | Used in the parser only, extract the 'RealSrcSpan' from an +-- 'EpaLocation'. The parser will never insert a 'DeltaPos', so the +-- partial function is safe. +epaLocationRealSrcSpan :: EpaLocation -> RealSrcSpan +epaLocationRealSrcSpan (EpaSpan r) = r +epaLocationRealSrcSpan (EpaDelta _) = panic "epaLocationRealSrcSpan" + +instance Outputable EpaLocation where + ppr (EpaSpan r) = text "EpaSpan" <+> ppr r + ppr (EpaDelta d) = text "EpaDelta" <+> ppr d instance Outputable AddEpAnn where ppr (AddEpAnn kw ss) = text "AddEpAnn" <+> ppr kw <+> ppr ss @@ -478,27 +498,27 @@ See Note [XRec and Anno in the AST] for details of how this is done. -- specialised to the specific set of locations of original API -- Annotation elements. So for 'HsLet' we have -- --- type instance XLet GhcPs = EpAnn' AnnsLet +-- type instance XLet GhcPs = EpAnn AnnsLet -- data AnnsLet -- = AnnsLet { --- alLet :: EpaAnchor, --- alIn :: EpaAnchor +-- alLet :: EpaLocation, +-- alIn :: EpaLocation -- } deriving Data -- --- The spacing between the items under the scope of a given EpAnn' is +-- The spacing between the items under the scope of a given EpAnn is -- derived from the original 'Anchor'. But there is no requirement -- that the items included in the sub-element have a "matching" -- location in their relative anchors. This allows us to freely move -- elements around, and stitch together new AST fragments out of old -- ones, and have them still printed out in a reasonable way. -data EpAnn' ann +data EpAnn ann = EpAnn { entry :: Anchor -- ^ Base location for the start of the syntactic element -- holding the annotations. , anns :: ann -- ^ Annotations added by the Parser , comments :: EpAnnComments -- ^ Comments enclosed in the SrcSpan of the element - -- this `EpAnn'` is attached to + -- this `EpAnn` is attached to } | EpAnnNotUsed -- ^ No Annotation for generated code, -- e.g. from TH, deriving, etc. @@ -550,19 +570,8 @@ data EpAnnComments = EpaComments type LEpaComment = GenLocated Anchor EpaComment -noCom :: EpAnnComments -noCom = EpaComments [] - -com :: [LEpaComment] -> EpAnnComments -com cs = EpaComments cs - --- --------------------------------------------------------------------- - --- | This type is the "vanilla" Exact Print Annotation. It captures --- the containing `SrcSpan' in its `entry` `Anchor`, has a list of --- `AddEpAnn`, and keeps track of the comments associated with the --- anchor. -type EpAnn = EpAnn' [AddEpAnn] +emptyComments :: EpAnnComments +emptyComments = EpaComments [] -- --------------------------------------------------------------------- -- Annotations attached to a 'SrcSpan'. @@ -576,7 +585,7 @@ data SrcSpanAnn' a = SrcSpanAnn { ann :: a, locA :: SrcSpan } -- See Note [XRec and Anno in the AST] -- | We mostly use 'SrcSpanAnn\'' with an 'EpAnn\'' -type SrcAnn ann = SrcSpanAnn' (EpAnn' ann) +type SrcAnn ann = SrcSpanAnn' (EpAnn ann) -- AZ: is SrcAnn the right abbreviation here? Any better suggestions? -- AZ: should we rename LocatedA to LocatedL? The name comes from @@ -642,11 +651,11 @@ meaning we can have type LocatedN RdrName -- | Captures the location of punctuation occuring between items, -- normally in a list. It is captured as a trailing annotation. data TrailingAnn - = AddSemiAnn EpaAnchor -- ^ Trailing ';' - | AddCommaAnn EpaAnchor -- ^ Trailing ',' - | AddVbarAnn EpaAnchor -- ^ Trailing '|' - | AddRarrowAnn EpaAnchor -- ^ Trailing '->' - | AddRarrowAnnU EpaAnchor -- ^ Trailing '->', unicode variant + = AddSemiAnn EpaLocation -- ^ Trailing ';' + | AddCommaAnn EpaLocation -- ^ Trailing ',' + | AddVbarAnn EpaLocation -- ^ Trailing '|' + | AddRarrowAnn EpaLocation -- ^ Trailing '->' + | AddRarrowAnnU EpaLocation -- ^ Trailing '->', unicode variant deriving (Data,Show,Eq, Ord) instance Outputable TrailingAnn where @@ -691,8 +700,8 @@ data AnnList data AnnParen = AnnParen { ap_adornment :: ParenType, - ap_open :: EpaAnchor, - ap_close :: EpaAnchor + ap_open :: EpaLocation, + ap_close :: EpaLocation } deriving (Data) -- | Detail of the "brackets" used in an 'AnnParen' API Annotation. @@ -714,10 +723,10 @@ parenTypeKws AnnParensSquare = (AnnOpenS, AnnCloseS) -- | API Annotation for the 'Context' data type. data AnnContext = AnnContext { - ac_darrow :: Maybe (IsUnicodeSyntax, EpaAnchor), + ac_darrow :: Maybe (IsUnicodeSyntax, EpaLocation), -- ^ location and encoding of the '=>', if present. - ac_open :: [EpaAnchor], -- ^ zero or more opening parentheses. - ac_close :: [EpaAnchor] -- ^ zero or more closing parentheses. + ac_open :: [EpaLocation], -- ^ zero or more opening parentheses. + ac_close :: [EpaLocation] -- ^ zero or more closing parentheses. } deriving (Data) @@ -732,35 +741,35 @@ data NameAnn -- | Used for a name with an adornment, so '`foo`', '(bar)' = NameAnn { nann_adornment :: NameAdornment, - nann_open :: EpaAnchor, - nann_name :: EpaAnchor, - nann_close :: EpaAnchor, + nann_open :: EpaLocation, + nann_name :: EpaLocation, + nann_close :: EpaLocation, nann_trailing :: [TrailingAnn] } -- | Used for @(,,,)@, or @(#,,,#)# | NameAnnCommas { nann_adornment :: NameAdornment, - nann_open :: EpaAnchor, - nann_commas :: [EpaAnchor], - nann_close :: EpaAnchor, + nann_open :: EpaLocation, + nann_commas :: [EpaLocation], + nann_close :: EpaLocation, nann_trailing :: [TrailingAnn] } -- | Used for @()@, @(##)@, @[]@ | NameAnnOnly { nann_adornment :: NameAdornment, - nann_open :: EpaAnchor, - nann_close :: EpaAnchor, + nann_open :: EpaLocation, + nann_close :: EpaLocation, nann_trailing :: [TrailingAnn] } -- | Used for @->@, as an identifier | NameAnnRArrow { - nann_name :: EpaAnchor, + nann_name :: EpaLocation, nann_trailing :: [TrailingAnn] } -- | Used for an item with a leading @'@. The annotation for -- unquoted item is stored in 'nann_quoted'. | NameAnnQuote { - nann_quote :: EpaAnchor, + nann_quote :: EpaLocation, nann_quoted :: SrcSpanAnnN, nann_trailing :: [TrailingAnn] } @@ -811,7 +820,7 @@ data AnnSortKey -- | Helper function used in the parser to add a 'TrailingAnn' items -- to an existing annotation. addTrailingAnnToL :: SrcSpan -> TrailingAnn -> EpAnnComments - -> EpAnn' AnnList -> EpAnn' AnnList + -> EpAnn AnnList -> EpAnn AnnList addTrailingAnnToL s t cs EpAnnNotUsed = EpAnn (spanAsAnchor s) (AnnList (Just $ spanAsAnchor s) Nothing Nothing [] [t]) cs addTrailingAnnToL _ t cs n = n { anns = addTrailing (anns n) @@ -822,7 +831,7 @@ addTrailingAnnToL _ t cs n = n { anns = addTrailing (anns n) -- | Helper function used in the parser to add a 'TrailingAnn' items -- to an existing annotation. addTrailingAnnToA :: SrcSpan -> TrailingAnn -> EpAnnComments - -> EpAnn' AnnListItem -> EpAnn' AnnListItem + -> EpAnn AnnListItem -> EpAnn AnnListItem addTrailingAnnToA s t cs EpAnnNotUsed = EpAnn (spanAsAnchor s) (AnnListItem [t]) cs addTrailingAnnToA _ t cs n = n { anns = addTrailing (anns n) @@ -832,12 +841,12 @@ addTrailingAnnToA _ t cs n = n { anns = addTrailing (anns n) -- | Helper function used in the parser to add a comma location to an -- existing annotation. -addTrailingCommaToN :: SrcSpan -> EpAnn' NameAnn -> EpaAnchor -> EpAnn' NameAnn +addTrailingCommaToN :: SrcSpan -> EpAnn NameAnn -> EpaLocation -> EpAnn NameAnn addTrailingCommaToN s EpAnnNotUsed l - = EpAnn (spanAsAnchor s) (NameAnnTrailing [AddCommaAnn l]) noCom + = EpAnn (spanAsAnchor s) (NameAnnTrailing [AddCommaAnn l]) emptyComments addTrailingCommaToN _ n l = n { anns = addTrailing (anns n) l } where - addTrailing :: NameAnn -> EpaAnchor -> NameAnn + addTrailing :: NameAnn -> EpaLocation -> NameAnn addTrailing n l = n { nann_trailing = AddCommaAnn l : nann_trailing n } -- --------------------------------------------------------------------- @@ -923,11 +932,11 @@ noSrcSpanA :: SrcAnn ann noSrcSpanA = noAnnSrcSpan noSrcSpan -- | Short form for 'EpAnnNotUsed' -noAnn :: EpAnn' a +noAnn :: EpAnn a noAnn = EpAnnNotUsed -addAnns :: EpAnn -> [AddEpAnn] -> EpAnnComments -> EpAnn +addAnns :: EpAnn [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn] addAnns (EpAnn l as1 cs) as2 cs2 = EpAnn (widenAnchor l (as1 ++ as2)) (as1 ++ as2) (cs <> cs2) addAnns EpAnnNotUsed [] (EpaComments []) = EpAnnNotUsed @@ -951,8 +960,8 @@ widenSpan :: SrcSpan -> [AddEpAnn] -> SrcSpan widenSpan s as = foldl combineSrcSpans s (go as) where go [] = [] - go (AddEpAnn _ (AR s):rest) = RealSrcSpan s Nothing : go rest - go (AddEpAnn _ (AD _):rest) = go rest + go (AddEpAnn _ (EpaSpan s):rest) = RealSrcSpan s Nothing : go rest + go (AddEpAnn _ (EpaDelta _):rest) = go rest -- | The annotations need to all come after the anchor. Make sure -- this is the case. @@ -960,8 +969,8 @@ widenRealSpan :: RealSrcSpan -> [AddEpAnn] -> RealSrcSpan widenRealSpan s as = foldl combineRealSrcSpans s (go as) where go [] = [] - go (AddEpAnn _ (AR s):rest) = s : go rest - go (AddEpAnn _ (AD _):rest) = go rest + go (AddEpAnn _ (EpaSpan s):rest) = s : go rest + go (AddEpAnn _ (EpaDelta _):rest) = go rest widenAnchor :: Anchor -> [AddEpAnn] -> Anchor widenAnchor (Anchor s op) as = Anchor (widenRealSpan s as) op @@ -972,22 +981,22 @@ widenAnchorR (Anchor s op) r = Anchor (combineRealSrcSpans s r) op widenLocatedAn :: SrcSpanAnn' an -> [AddEpAnn] -> SrcSpanAnn' an widenLocatedAn (SrcSpanAnn a l) as = SrcSpanAnn a (widenSpan l as) -epAnnAnnsL :: EpAnn' a -> [a] +epAnnAnnsL :: EpAnn a -> [a] epAnnAnnsL EpAnnNotUsed = [] epAnnAnnsL (EpAnn _ anns _) = [anns] -epAnnAnns :: EpAnn -> [AddEpAnn] +epAnnAnns :: EpAnn [AddEpAnn] -> [AddEpAnn] epAnnAnns EpAnnNotUsed = [] epAnnAnns (EpAnn _ anns _) = anns -annParen2AddEpAnn :: EpAnn' AnnParen -> [AddEpAnn] +annParen2AddEpAnn :: EpAnn AnnParen -> [AddEpAnn] annParen2AddEpAnn EpAnnNotUsed = [] annParen2AddEpAnn (EpAnn _ (AnnParen pt o c) _) = [AddEpAnn ai o, AddEpAnn ac c] where (ai,ac) = parenTypeKws pt -epAnnComments :: EpAnn' an -> EpAnnComments +epAnnComments :: EpAnn an -> EpAnnComments epAnnComments EpAnnNotUsed = EpaComments [] epAnnComments (EpAnn _ _ cs) = cs @@ -1036,13 +1045,13 @@ setPriorComments (EpaCommentsBalanced _ ts) cs = EpaCommentsBalanced cs ts -- --------------------------------------------------------------------- -- TODO:AZ I think EpAnnCO is not needed -type EpAnnCO = EpAnn' NoEpAnns -- ^ Api Annotations for comments only +type EpAnnCO = EpAnn NoEpAnns -- ^ Api Annotations for comments only data NoEpAnns = NoEpAnns deriving (Data,Eq,Ord) noComments ::EpAnnCO -noComments = EpAnn (Anchor placeholderRealSpan UnchangedAnchor) NoEpAnns noCom +noComments = EpAnn (Anchor placeholderRealSpan UnchangedAnchor) NoEpAnns emptyComments -- TODO:AZ get rid of this placeholderRealSpan :: RealSrcSpan @@ -1052,7 +1061,7 @@ comment :: RealSrcSpan -> EpAnnComments -> EpAnnCO comment loc cs = EpAnn (Anchor loc UnchangedAnchor) NoEpAnns cs -- --------------------------------------------------------------------- --- Utilities for managing comments in an `EpAnn' a` structure. +-- Utilities for managing comments in an `EpAnn a` structure. -- --------------------------------------------------------------------- -- | Add additional comments to a 'SrcAnn', used for manipulating the @@ -1074,7 +1083,7 @@ setCommentsSrcAnn (SrcSpanAnn (EpAnn a an _) loc) cs -- | Add additional comments, used for manipulating the -- AST prior to exact printing the changed one. addCommentsToEpAnn :: (Monoid a) - => SrcSpan -> EpAnn' a -> EpAnnComments -> EpAnn' a + => SrcSpan -> EpAnn a -> EpAnnComments -> EpAnn a addCommentsToEpAnn loc EpAnnNotUsed cs = EpAnn (Anchor (realSrcSpan loc) UnchangedAnchor) mempty cs addCommentsToEpAnn _ (EpAnn a an ocs) ncs = EpAnn a an (ocs <> ncs) @@ -1082,7 +1091,7 @@ addCommentsToEpAnn _ (EpAnn a an ocs) ncs = EpAnn a an (ocs <> ncs) -- | Replace any existing comments, used for manipulating the -- AST prior to exact printing the changed one. setCommentsEpAnn :: (Monoid a) - => SrcSpan -> EpAnn' a -> EpAnnComments -> EpAnn' a + => SrcSpan -> EpAnn a -> EpAnnComments -> EpAnn a setCommentsEpAnn loc EpAnnNotUsed cs = EpAnn (Anchor (realSrcSpan loc) UnchangedAnchor) mempty cs setCommentsEpAnn _ (EpAnn a an _) cs = EpAnn a an cs @@ -1094,7 +1103,7 @@ transferComments :: (Monoid ann) => SrcAnn ann -> SrcAnn ann -> (SrcAnn ann, SrcAnn ann) transferComments from@(SrcSpanAnn EpAnnNotUsed _) to = (from, to) transferComments (SrcSpanAnn (EpAnn a an cs) l) to - = ((SrcSpanAnn (EpAnn a an noCom) l), addCommentsToSrcAnn to cs) + = ((SrcSpanAnn (EpAnn a an emptyComments) l), addCommentsToSrcAnn to cs) -- --------------------------------------------------------------------- -- Semigroup instances, to allow easy combination of annotaion elements @@ -1106,7 +1115,7 @@ instance (Semigroup an) => Semigroup (SrcSpanAnn' an) where -- annotations must follow it. So we combine them which yields the -- largest span -instance (Semigroup a) => Semigroup (EpAnn' a) where +instance (Semigroup a) => Semigroup (EpAnn a) where EpAnnNotUsed <> x = x x <> EpAnnNotUsed = x (EpAnn l1 a1 b1) <> (EpAnn l2 a2 b2) = EpAnn (l1 <> l2) (a1 <> a2) (b1 <> b2) @@ -1127,7 +1136,7 @@ instance Semigroup EpAnnComments where EpaCommentsBalanced cs1 as1 <> EpaCommentsBalanced cs2 as2 = EpaCommentsBalanced (cs1 ++ cs2) (as1++as2) -instance (Monoid a) => Monoid (EpAnn' a) where +instance (Monoid a) => Monoid (EpAnn a) where mempty = EpAnnNotUsed instance Semigroup AnnListItem where @@ -1164,7 +1173,7 @@ instance Semigroup AnnSortKey where instance Monoid AnnSortKey where mempty = NoAnnSortKey -instance (Outputable a) => Outputable (EpAnn' a) where +instance (Outputable a) => Outputable (EpAnn a) where ppr (EpAnn l a c) = text "EpAnn" <+> ppr l <+> ppr a <+> ppr c ppr EpAnnNotUsed = text "EpAnnNotUsed" @@ -1176,7 +1185,8 @@ instance Outputable AnchorOperation where ppr (MovedAnchor d) = text "MovedAnchor" <+> ppr d instance Outputable DeltaPos where - ppr (DP l c) = text "DP" <+> ppr l <+> ppr c + ppr (SameLine c) = text "SameLine" <+> ppr c + ppr (DifferentLine l c) = text "DifferentLine" <+> ppr l <+> ppr c instance Outputable (GenLocated Anchor EpaComment) where ppr (L l c) = text "L" <+> ppr l <+> ppr c diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x index fef3b8b8c3..c813ab33e2 100644 --- a/compiler/GHC/Parser/Lexer.x +++ b/compiler/GHC/Parser/Lexer.x @@ -2935,15 +2935,15 @@ instance MonadP P where getCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments getCommentsFor (RealSrcSpan l _) = allocateCommentsP l -getCommentsFor _ = return noCom +getCommentsFor _ = return emptyComments getPriorCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments getPriorCommentsFor (RealSrcSpan l _) = allocatePriorCommentsP l -getPriorCommentsFor _ = return noCom +getPriorCommentsFor _ = return emptyComments getFinalCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments getFinalCommentsFor (RealSrcSpan l _) = allocateFinalCommentsP l -getFinalCommentsFor _ = return noCom +getFinalCommentsFor _ = return emptyComments getEofPos :: P (Maybe (RealSrcSpan, RealSrcSpan)) getEofPos = P $ \s@(PState { eof_pos = pos }) -> POk s pos @@ -3438,7 +3438,7 @@ clean_pragma prag = canon_ws (map toLower (unprefix prag)) -- and end of the span mkParensEpAnn :: SrcSpan -> [AddEpAnn] mkParensEpAnn (UnhelpfulSpan _) = [] -mkParensEpAnn (RealSrcSpan ss _) = [AddEpAnn AnnOpenP (AR lo),AddEpAnn AnnCloseP (AR lc)] +mkParensEpAnn (RealSrcSpan ss _) = [AddEpAnn AnnOpenP (EpaSpan lo),AddEpAnn AnnCloseP (EpaSpan lc)] where f = srcSpanFile ss sl = srcSpanStartLine ss diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 2686bc151b..1de9f0cd53 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -189,7 +189,7 @@ mkClassDecl loc' (L _ (mcxt, tycl_hdr)) fds where_cls layoutInfo annsIn ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr ; (tyvars,annst) <- checkTyVars (text "class") whereDots cls tparams ; cs <- getCommentsFor (locA loc) -- Get any remaining comments - ; let anns' = addAnns (EpAnn (spanAsAnchor $ locA loc) annsIn noCom) (ann++annst) cs + ; let anns' = addAnns (EpAnn (spanAsAnchor $ locA loc) annsIn emptyComments) (ann++annst) cs ; return (L loc (ClassDecl { tcdCExt = (anns', NoAnnSortKey, layoutInfo) , tcdCtxt = mcxt , tcdLName = cls, tcdTyVars = tyvars @@ -215,7 +215,7 @@ mkTyData loc' new_or_data cType (L _ (mcxt, tycl_hdr)) ; (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr ; (tyvars, anns) <- checkTyVars (ppr new_or_data) equalsDots tc tparams ; cs <- getCommentsFor (locA loc) -- Get any remaining comments - ; let anns' = addAnns (EpAnn (spanAsAnchor $ locA loc) annsIn noCom) (ann ++ anns) cs + ; let anns' = addAnns (EpAnn (spanAsAnchor $ locA loc) annsIn emptyComments) (ann ++ anns) cs ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv anns' ; return (L loc (DataDecl { tcdDExt = anns', -- AZ: do we need these? tcdLName = tc, tcdTyVars = tyvars, @@ -228,7 +228,7 @@ mkDataDefn :: NewOrData -> Maybe (LHsKind GhcPs) -> [LConDecl GhcPs] -> HsDeriving GhcPs - -> EpAnn + -> EpAnn [AddEpAnn] -> P (HsDataDefn GhcPs) mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv ann = do { checkDatatypeContext mcxt @@ -250,7 +250,7 @@ mkTySynonym loc lhs rhs annsIn ; cs1 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp] ; (tyvars, anns) <- checkTyVars (text "type") equalsDots tc tparams ; cs2 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp] - ; let anns' = addAnns (EpAnn (spanAsAnchor loc) annsIn noCom) (ann ++ anns) (cs1 Semi.<> cs2) + ; let anns' = addAnns (EpAnn (spanAsAnchor loc) annsIn emptyComments) (ann ++ anns) (cs1 Semi.<> cs2) ; return (L (noAnnSrcSpan loc) (SynDecl { tcdSExt = anns' , tcdLName = tc, tcdTyVars = tyvars @@ -312,7 +312,7 @@ mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr) = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr ; -- AZ:TODO: deal with these comments ; cs <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp] - ; let anns' = addAnns (EpAnn (spanAsAnchor loc) ann cs) anns noCom + ; let anns' = addAnns (EpAnn (spanAsAnchor loc) ann cs) anns emptyComments ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv anns' ; return (L (noAnnSrcSpan loc) (DataFamInstD anns' (DataFamInstDecl (FamEqn { feqn_ext = noAnn -- AZ: get anns @@ -344,7 +344,7 @@ mkFamDecl loc info topLevel lhs ksig injAnn annsIn ; cs1 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp] ; (tyvars, anns) <- checkTyVars (ppr info) equals_or_where tc tparams ; cs2 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp] - ; let anns' = addAnns (EpAnn (spanAsAnchor loc) annsIn noCom) (ann++anns) (cs1 Semi.<> cs2) + ; let anns' = addAnns (EpAnn (spanAsAnchor loc) annsIn emptyComments) (ann++anns) (cs1 Semi.<> cs2) ; return (L (noAnnSrcSpan loc) (FamDecl noExtField (FamilyDecl { fdExt = anns' @@ -436,17 +436,17 @@ annBinds a (HsValBinds an bs) = (HsValBinds (add_where a an) bs) annBinds a (HsIPBinds an bs) = (HsIPBinds (add_where a an) bs) annBinds _ (EmptyLocalBinds x) = (EmptyLocalBinds x) -add_where :: AddEpAnn -> EpAnn' AnnList -> EpAnn' AnnList -add_where an@(AddEpAnn _ (AR rs)) (EpAnn a (AnnList anc o c r t) cs) +add_where :: AddEpAnn -> EpAnn AnnList -> EpAnn AnnList +add_where an@(AddEpAnn _ (EpaSpan rs)) (EpAnn a (AnnList anc o c r t) cs) | valid_anchor (anchor a) = EpAnn (widenAnchor a [an]) (AnnList anc o c (an:r) t) cs | otherwise = EpAnn (patch_anchor rs a) (AnnList (fmap (patch_anchor rs) anc) o c (an:r) t) cs -add_where an@(AddEpAnn _ (AR rs)) EpAnnNotUsed +add_where an@(AddEpAnn _ (EpaSpan rs)) EpAnnNotUsed = EpAnn (Anchor rs UnchangedAnchor) - (AnnList (Just $ Anchor rs UnchangedAnchor) Nothing Nothing [an] []) noCom -add_where (AddEpAnn _ (AD _)) _ = panic "add_where" - -- AD should only be used for transformations + (AnnList (Just $ Anchor rs UnchangedAnchor) Nothing Nothing [an] []) emptyComments +add_where (AddEpAnn _ (EpaDelta _)) _ = panic "add_where" + -- EpaDelta should only be used for transformations valid_anchor :: RealSrcSpan -> Bool valid_anchor r = srcSpanStartLine r >= 0 @@ -679,7 +679,7 @@ recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a recordPatSynErr loc pat = addFatalError $ PsError (PsErrRecordSyntaxInPatSynDecl pat) [] loc -mkConDeclH98 :: EpAnn -> LocatedN RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs] +mkConDeclH98 :: EpAnn [AddEpAnn] -> LocatedN RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs] -> Maybe (LHsContext GhcPs) -> HsConDeclH98Details GhcPs -> ConDecl GhcPs @@ -833,7 +833,7 @@ checkTyVars pp_what equals_or_where tc tparms ; return (mkHsQTvs tvs, concat anns) } where check (HsTypeArg _ ki@(L loc _)) = addFatalError $ PsError (PsErrUnexpectedTypeAppInDecl ki pp_what (unLoc tc)) [] (locA loc) - check (HsValArg ty) = chkParens [] noCom ty + check (HsValArg ty) = chkParens [] emptyComments ty check (HsArgPar sp) = addFatalError $ PsError (PsErrMalformedDecl pp_what (unLoc tc)) [] sp -- Keep around an action for adjusting the annotations of extra parens chkParens :: [AddEpAnn] -> EpAnnComments -> LHsType GhcPs @@ -869,7 +869,7 @@ checkDatatypeContext (Just c) unless allowed $ addError $ PsError (PsErrIllegalDataTypeContext c) [] (getLocA c) type LRuleTyTmVar = Located RuleTyTmVar -data RuleTyTmVar = RuleTyTmVar EpAnn (LocatedN RdrName) (Maybe (LHsType GhcPs)) +data RuleTyTmVar = RuleTyTmVar (EpAnn [AddEpAnn]) (LocatedN RdrName) (Maybe (LHsType GhcPs)) -- ^ Essentially a wrapper for a @RuleBndr GhcPs@ -- turns RuleTyTmVars into RuleBnrs - this is straightforward @@ -960,18 +960,18 @@ checkTyClHdr is_cls ty -- Combine the annotations from the HsParTy and HsStarTy into a -- new one for the LocatedN RdrName - newAnns :: SrcSpanAnnA -> EpAnn' AnnParen -> SrcSpanAnnN + newAnns :: SrcSpanAnnA -> EpAnn AnnParen -> SrcSpanAnnN newAnns (SrcSpanAnn EpAnnNotUsed l) (EpAnn as (AnnParen _ o c) cs) = let lr = combineRealSrcSpans (realSrcSpan l) (anchor as) -- lr = widenAnchorR as (realSrcSpan l) - an = (EpAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (AR $ realSrcSpan l) c []) cs) + an = (EpAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (EpaSpan $ realSrcSpan l) c []) cs) in SrcSpanAnn an (RealSrcSpan lr Nothing) newAnns _ EpAnnNotUsed = panic "missing AnnParen" newAnns (SrcSpanAnn (EpAnn ap (AnnListItem ta) csp) l) (EpAnn as (AnnParen _ o c) cs) = let lr = combineRealSrcSpans (anchor ap) (anchor as) - an = (EpAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (AR $ realSrcSpan l) c ta) (csp Semi.<> cs)) + an = (EpAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (EpaSpan $ realSrcSpan l) c ta) (csp Semi.<> cs)) in SrcSpanAnn an (RealSrcSpan lr Nothing) -- | Yield a parse error if we have a function applied directly to a do block @@ -1017,9 +1017,9 @@ checkCmdBlockArguments :: LHsCmd GhcPs -> PV () -- @ checkContext :: LHsType GhcPs -> P (LHsContext GhcPs) checkContext orig_t@(L (SrcSpanAnn _ l) _orig_t) = - check ([],[],noCom) orig_t + check ([],[],emptyComments) orig_t where - check :: ([EpaAnchor],[EpaAnchor],EpAnnComments) + check :: ([EpaLocation],[EpaLocation],EpAnnComments) -> LHsType GhcPs -> P (LHsContext GhcPs) check (oparens,cparens,cs) (L _l (HsTupleTy ann' HsBoxedOrConstraintTuple ts)) -- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can @@ -1027,7 +1027,7 @@ checkContext orig_t@(L (SrcSpanAnn _ l) _orig_t) = -- Ditto () = do let (op,cp,cs') = case ann' of - EpAnnNotUsed -> ([],[],noCom) + EpAnnNotUsed -> ([],[],emptyComments) EpAnn _ (AnnParen _ o c) cs -> ([o],[c],cs) return (L (SrcSpanAnn (EpAnn (spanAsAnchor l) (AnnContext Nothing (op Semi.<> oparens) (cp Semi.<> cparens)) (cs Semi.<> cs')) l) ts) @@ -1036,16 +1036,16 @@ checkContext orig_t@(L (SrcSpanAnn _ l) _orig_t) = -- to be sure HsParTy doesn't get into the way = do let (op,cp,cs') = case ann' of - EpAnnNotUsed -> ([],[],noCom) + EpAnnNotUsed -> ([],[],emptyComments) EpAnn _ (AnnParen _ open close ) cs -> ([open],[close],cs) check (op++opi,cp++cpi,cs' Semi.<> csi) ty -- No need for anns, returning original check (_opi,_cpi,_csi) _t = - return (L (SrcSpanAnn (EpAnn (spanAsAnchor l) (AnnContext Nothing [] []) noCom) l) [orig_t]) + return (L (SrcSpanAnn (EpAnn (spanAsAnchor l) (AnnContext Nothing [] []) emptyComments) l) [orig_t]) -checkImportDecl :: Maybe EpaAnchor - -> Maybe EpaAnchor +checkImportDecl :: Maybe EpaLocation + -> Maybe EpaLocation -> P () checkImportDecl mPre mPost = do let whenJust mg f = maybe (pure ()) f mg @@ -1056,18 +1056,18 @@ checkImportDecl mPre mPost = do -- 'ImportQualifiedPost' is not in effect. whenJust mPost $ \post -> when (not importQualifiedPostEnabled) $ - failOpNotEnabledImportQualifiedPost (RealSrcSpan (epaAnchorRealSrcSpan post) Nothing) + failOpNotEnabledImportQualifiedPost (RealSrcSpan (epaLocationRealSrcSpan post) Nothing) -- Error if 'qualified' occurs in both pre and postpositive -- positions. whenJust mPost $ \post -> when (isJust mPre) $ - failOpImportQualifiedTwice (RealSrcSpan (epaAnchorRealSrcSpan post) Nothing) + failOpImportQualifiedTwice (RealSrcSpan (epaLocationRealSrcSpan post) Nothing) -- Warn if 'qualified' found in prepositive position and -- 'Opt_WarnPrepositiveQualifiedModule' is enabled. whenJust mPre $ \pre -> - warnPrepositiveQualifiedModule (RealSrcSpan (epaAnchorRealSrcSpan pre) Nothing) + warnPrepositiveQualifiedModule (RealSrcSpan (epaLocationRealSrcSpan pre) Nothing) -- ------------------------------------------------------------------------- -- Checking Patterns. @@ -1148,7 +1148,7 @@ checkAPat loc e0 = do (L l p) <- checkLPat e let aa = [AddEpAnn ai o, AddEpAnn ac c] (ai,ac) = parenTypeKws pt - return (ParPat (EpAnn (spanAsAnchor $ (widenSpan (locA l) aa)) an noCom) (L l p)) + return (ParPat (EpAnn (spanAsAnchor $ (widenSpan (locA l) aa)) an emptyComments) (L l p)) _ -> patFail (locA loc) (ppr e0) placeHolderPunRhs :: DisambECP b => PV (LocatedA b) @@ -1306,7 +1306,7 @@ isFunLhs e = go e [] [] _ -> return Nothing } go _ _ _ = return Nothing -mkBangTy :: EpAnn -> SrcStrictness -> LHsType GhcPs -> HsType GhcPs +mkBangTy :: EpAnn [AddEpAnn] -> SrcStrictness -> LHsType GhcPs -> HsType GhcPs mkBangTy anns strictness = HsBangTy anns (HsSrcBang NoSourceText NoSrcUnpack strictness) @@ -1381,7 +1381,7 @@ type Fbind b = Either (LHsRecField GhcPs (LocatedA b)) (LHsRecProj GhcPs (Locate class DisambInfixOp b where mkHsVarOpPV :: LocatedN RdrName -> PV (LocatedN b) mkHsConOpPV :: LocatedN RdrName -> PV (LocatedN b) - mkHsInfixHolePV :: SrcSpan -> (EpAnnComments -> EpAnn' EpAnnUnboundVar) -> PV (Located b) + mkHsInfixHolePV :: SrcSpan -> (EpAnnComments -> EpAnn EpAnnUnboundVar) -> PV (Located b) instance DisambInfixOp (HsExpr GhcPs) where mkHsVarOpPV v = return $ L (getLoc v) (HsVar noExtField v) @@ -1719,7 +1719,7 @@ instance DisambECP (HsExpr GhcPs) where rejectPragmaPV (L l (HsPragE _ prag _)) = addError $ PsError (PsErrUnallowedPragma prag) [] (locA l) rejectPragmaPV _ = return () -hsHoleExpr :: EpAnn' EpAnnUnboundVar -> HsExpr GhcPs +hsHoleExpr :: EpAnn EpAnnUnboundVar -> HsExpr GhcPs hsHoleExpr anns = HsUnboundVar anns (mkVarOcc "_") type instance Anno (GRHS GhcPs (LocatedA (PatBuilder GhcPs))) = SrcSpan @@ -1811,7 +1811,7 @@ checkUnboxedStringLitPat (L loc lit) = mkPatRec :: LocatedA (PatBuilder GhcPs) -> HsRecFields GhcPs (LocatedA (PatBuilder GhcPs)) -> - EpAnn -> + EpAnn [AddEpAnn] -> PV (PatBuilder GhcPs) mkPatRec (unLoc -> PatBuilderVar c) (HsRecFields fs dd) anns | isRdrDataCon (unLoc c) @@ -2377,7 +2377,7 @@ mkRecConstrOrUpdate -> LHsExpr GhcPs -> SrcSpan -> ([Fbind (HsExpr GhcPs)], Maybe SrcSpan) - -> EpAnn + -> EpAnn [AddEpAnn] -> PV (HsExpr GhcPs) mkRecConstrOrUpdate _ (L _ (HsVar _ (L l c))) _lrec (fbinds,dd) anns | isRdrDataCon c @@ -2390,7 +2390,7 @@ mkRecConstrOrUpdate overloaded_update exp _ (fs,dd) anns | Just dd_loc <- dd = addFatalError $ PsError PsErrDotsInRecordUpdate [] dd_loc | otherwise = mkRdrRecordUpd overloaded_update exp fs anns -mkRdrRecordUpd :: Bool -> LHsExpr GhcPs -> [Fbind (HsExpr GhcPs)] -> EpAnn -> PV (HsExpr GhcPs) +mkRdrRecordUpd :: Bool -> LHsExpr GhcPs -> [Fbind (HsExpr GhcPs)] -> EpAnn [AddEpAnn] -> PV (HsExpr GhcPs) mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds anns = do -- We do not need to know if OverloadedRecordDot is in effect. We do -- however need to know if OverloadedRecordUpdate (passed in @@ -2443,7 +2443,7 @@ mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds anns = do punnedVar f = if not pun then arg else noLocA . HsVar noExtField . noLocA . mkRdrUnqual . mkVarOccFS $ f mkRdrRecordCon - :: LocatedN RdrName -> HsRecordBinds GhcPs -> EpAnn -> HsExpr GhcPs + :: LocatedN RdrName -> HsRecordBinds GhcPs -> EpAnn [AddEpAnn] -> HsExpr GhcPs mkRdrRecordCon con flds anns = RecordCon { rcon_ext = anns, rcon_con = con, rcon_flds = flds } @@ -2482,7 +2482,7 @@ mkInlinePragma src (inl, match_info) mb_act mkImport :: Located CCallConv -> Located Safety -> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs) - -> P (EpAnn -> HsDecl GhcPs) + -> P (EpAnn [AddEpAnn] -> HsDecl GhcPs) mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) = case unLoc cconv of CCallConv -> mkCImport @@ -2583,7 +2583,7 @@ parseCImport cconv safety nm str sourceText = -- mkExport :: Located CCallConv -> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs) - -> P (EpAnn -> HsDecl GhcPs) + -> P (EpAnn [AddEpAnn] -> HsDecl GhcPs) mkExport (L lc cconv) (L le (StringLiteral esrc entity _), v, ty) = return $ \ann -> ForD noExtField $ ForeignExport { fd_e_ext = ann, fd_name = v, fd_sig_ty = ty @@ -2611,7 +2611,7 @@ data ImpExpSubSpec = ImpExpAbs | ImpExpAllWith [LocatedA ImpExpQcSpec] data ImpExpQcSpec = ImpExpQcName (LocatedN RdrName) - | ImpExpQcType EpaAnchor (LocatedN RdrName) + | ImpExpQcType EpaLocation (LocatedN RdrName) | ImpExpQcWildcard mkModuleImpExp :: [AddEpAnn] -> LocatedA ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs) @@ -2677,7 +2677,7 @@ checkImportSpec ie@(L _ specs) = mkImpExpSubSpec :: [LocatedA ImpExpQcSpec] -> P ([AddEpAnn], ImpExpSubSpec) mkImpExpSubSpec [] = return ([], ImpExpList []) mkImpExpSubSpec [L la ImpExpQcWildcard] = - return ([AddEpAnn AnnDotdot (AR $ la2r la)], ImpExpAll) + return ([AddEpAnn AnnDotdot (EpaSpan $ la2r la)], ImpExpAll) mkImpExpSubSpec xs = if (any (isImpExpQcWildcard . unLoc) xs) then return $ ([], ImpExpAllWith xs) @@ -2885,7 +2885,7 @@ mkSumOrTupleExpr l boxity (Tuple es) anns = do cs <- getCommentsFor (locA l) return $ L l (ExplicitTuple (EpAnn (spanAsAnchor $ locA l) anns cs) (map toTupArg es) boxity) where - toTupArg :: Either (EpAnn' EpaAnchor) (LHsExpr GhcPs) -> HsTupArg GhcPs + toTupArg :: Either (EpAnn EpaLocation) (LHsExpr GhcPs) -> HsTupArg GhcPs toTupArg (Left ann) = missingTupArg ann toTupArg (Right a) = Present noAnn a @@ -2912,7 +2912,7 @@ mkSumOrTuplePat l boxity (Tuple ps) anns = do cs <- getCommentsFor (locA l) return $ L l (PatBuilderPat (TuplePat (EpAnn (spanAsAnchor $ locA l) anns cs) ps' boxity)) where - toTupPat :: Either (EpAnn' EpaAnchor) (LocatedA (PatBuilder GhcPs)) -> PV (LPat GhcPs) + toTupPat :: Either (EpAnn EpaLocation) (LocatedA (PatBuilder GhcPs)) -> PV (LPat GhcPs) -- Ignore the element location so that the error message refers to the -- entire tuple. See #19504 (and the discussion) for details. toTupPat p = case p of @@ -2936,8 +2936,8 @@ mkLHsOpTy x op y = mkMultTy :: IsUnicodeSyntax -> Located Token -> LHsType GhcPs -> HsArrow GhcPs mkMultTy u tok t@(L _ (HsTyLit _ (HsNumTy (SourceText "1") 1))) -- See #18888 for the use of (SourceText "1") above - = HsLinearArrow u (Just $ AddEpAnn AnnPercentOne (AR $ realSrcSpan $ combineLocs tok (reLoc t))) -mkMultTy u tok t = HsExplicitMult u (Just $ AddEpAnn AnnPercent (AR $ realSrcSpan $ getLoc tok)) t + = HsLinearArrow u (Just $ AddEpAnn AnnPercentOne (EpaSpan $ realSrcSpan $ combineLocs tok (reLoc t))) +mkMultTy u tok t = HsExplicitMult u (Just $ AddEpAnn AnnPercent (EpaSpan $ realSrcSpan $ getLoc tok)) t ----------------------------------------------------------------------------- -- Token symbols @@ -2958,7 +2958,7 @@ mkRdrGetField loc arg field anns = , gf_field = field } -mkRdrProjection :: [Located (HsFieldLabel GhcPs)] -> EpAnn' AnnProjection -> HsExpr GhcPs +mkRdrProjection :: [Located (HsFieldLabel GhcPs)] -> EpAnn AnnProjection -> HsExpr GhcPs mkRdrProjection [] _ = panic "mkRdrProjection: The impossible has happened!" mkRdrProjection flds anns = HsProjection { @@ -2967,7 +2967,7 @@ mkRdrProjection flds anns = } mkRdrProjUpdate :: SrcSpanAnnA -> Located [Located (HsFieldLabel GhcPs)] - -> LHsExpr GhcPs -> Bool -> EpAnn + -> LHsExpr GhcPs -> Bool -> EpAnn [AddEpAnn] -> LHsRecProj GhcPs (LHsExpr GhcPs) mkRdrProjUpdate _ (L _ []) _ _ _ = panic "mkRdrProjUpdate: The impossible has happened!" mkRdrProjUpdate loc (L l flds) arg isPun anns = diff --git a/compiler/GHC/Parser/Types.hs b/compiler/GHC/Parser/Types.hs index 2f5f304009..5369367ed2 100644 --- a/compiler/GHC/Parser/Types.hs +++ b/compiler/GHC/Parser/Types.hs @@ -26,9 +26,9 @@ import GHC.Parser.Annotation import Language.Haskell.Syntax data SumOrTuple b - = Sum ConTag Arity (LocatedA b) [EpaAnchor] [EpaAnchor] + = Sum ConTag Arity (LocatedA b) [EpaLocation] [EpaLocation] -- ^ Last two are the locations of the '|' before and after the payload - | Tuple [Either (EpAnn' EpaAnchor) (LocatedA b)] + | Tuple [Either (EpAnn EpaLocation) (LocatedA b)] pprSumOrTuple :: Outputable b => Boxity -> SumOrTuple b -> SDoc pprSumOrTuple boxity = \case @@ -56,7 +56,7 @@ data PatBuilder p | PatBuilderApp (LocatedA (PatBuilder p)) (LocatedA (PatBuilder p)) | PatBuilderAppType (LocatedA (PatBuilder p)) SrcSpan (HsPatSigType GhcPs) | PatBuilderOpApp (LocatedA (PatBuilder p)) (LocatedN RdrName) - (LocatedA (PatBuilder p)) EpAnn + (LocatedA (PatBuilder p)) (EpAnn [AddEpAnn]) | PatBuilderVar (LocatedN RdrName) | PatBuilderOverLit (HsOverLit GhcPs) diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index 0502d8d962..32d9bd0da8 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -1868,14 +1868,14 @@ printMinimalImports hsc_src imports_w_usage to_ie_post_rn_var :: (HasOccName name) => LocatedA name -> LIEWrappedName name to_ie_post_rn_var (L l n) - | isDataOcc $ occName n = L l (IEPattern (AR $ la2r l) (L (la2na l) n)) - | otherwise = L l (IEName (L (la2na l) n)) + | isDataOcc $ occName n = L l (IEPattern (EpaSpan $ la2r l) (L (la2na l) n)) + | otherwise = L l (IEName (L (la2na l) n)) to_ie_post_rn :: (HasOccName name) => LocatedA name -> LIEWrappedName name to_ie_post_rn (L l n) - | isTcOcc occ && isSymOcc occ = L l (IEType (AR $ la2r l) (L (la2na l) n)) - | otherwise = L l (IEName (L (la2na l) n)) + | isTcOcc occ && isSymOcc occ = L l (IEType (EpaSpan $ la2r l) (L (la2na l) n)) + | otherwise = L l (IEName (L (la2na l) n)) where occ = occName n {- diff --git a/compiler/GHC/Stg/CSE.hs b/compiler/GHC/Stg/CSE.hs index bc266d20ba..01d1c4b518 100644 --- a/compiler/GHC/Stg/CSE.hs +++ b/compiler/GHC/Stg/CSE.hs @@ -203,19 +203,46 @@ initEnv in_scope = CseEnv , ce_in_scope = in_scope } +------------------- +normaliseConArgs :: CseEnv -> [OutStgArg] -> [OutStgArg] +-- See Note [Trivial case scrutinee] +normaliseConArgs env args + = map go args + where + bndr_map = ce_bndrMap env + go (StgVarArg v ) = StgVarArg (normaliseId bndr_map v) + go (StgLitArg lit) = StgLitArg lit + +normaliseId :: IdEnv OutId -> OutId -> OutId +normaliseId bndr_map v = case lookupVarEnv bndr_map v of + Just v' -> v' + Nothing -> v + +addTrivCaseBndr :: OutId -> OutId -> CseEnv -> CseEnv +-- See Note [Trivial case scrutinee] +addTrivCaseBndr from to env + = env { ce_bndrMap = extendVarEnv bndr_map from norm_to } + where + bndr_map = ce_bndrMap env + norm_to = normaliseId bndr_map to + envLookup :: DataCon -> [OutStgArg] -> CseEnv -> Maybe OutId -envLookup dataCon args env = lookupTM (dataCon, args') (ce_conAppMap env) - where args' = map go args -- See Note [Trivial case scrutinee] - go (StgVarArg v ) = StgVarArg (fromMaybe v $ lookupVarEnv (ce_bndrMap env) v) - go (StgLitArg lit) = StgLitArg lit +envLookup dataCon args env + = lookupTM (dataCon, normaliseConArgs env args) + (ce_conAppMap env) + -- normaliseConArgs: See Note [Trivial case scrutinee] addDataCon :: OutId -> DataCon -> [OutStgArg] -> CseEnv -> CseEnv --- do not bother with nullary data constructors, they are static anyways +-- Do not bother with nullary data constructors; they are static anyway addDataCon _ _ [] env = env -addDataCon bndr dataCon args env = env { ce_conAppMap = new_env } +addDataCon bndr dataCon args env + = env { ce_conAppMap = new_env } where - new_env = insertTM (dataCon, args) bndr (ce_conAppMap env) + new_env = insertTM (dataCon, normaliseConArgs env args) + bndr (ce_conAppMap env) + -- normaliseConArgs: See Note [Trivial case scrutinee] +------------------- forgetCse :: CseEnv -> CseEnv forgetCse env = env { ce_conAppMap = emptyTM } -- See note [Free variables of an StgClosure] @@ -224,10 +251,6 @@ addSubst :: OutId -> OutId -> CseEnv -> CseEnv addSubst from to env = env { ce_subst = extendVarEnv (ce_subst env) from to } -addTrivCaseBndr :: OutId -> OutId -> CseEnv -> CseEnv -addTrivCaseBndr from to env - = env { ce_bndrMap = extendVarEnv (ce_bndrMap env) from to } - substArgs :: CseEnv -> [InStgArg] -> [OutStgArg] substArgs env = map (substArg env) @@ -318,9 +341,11 @@ stgCseExpr env (StgCase scrut bndr ty alts) where scrut' = stgCseExpr env scrut (env1, bndr') = substBndr env bndr - env2 | StgApp trivial_scrut [] <- scrut' = addTrivCaseBndr bndr trivial_scrut env1 + env2 | StgApp trivial_scrut [] <- scrut' + = addTrivCaseBndr bndr trivial_scrut env1 -- See Note [Trivial case scrutinee] - | otherwise = env1 + | otherwise + = env1 alts' = map (stgCseAlt env2 ty bndr') alts @@ -468,25 +493,70 @@ we can. Note [Trivial case scrutinee] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We want to be able to handle nested reconstruction of constructors as in +We want to be able to CSE nested reconstruction of constructors as in nested :: Either Int (Either Int a) -> Either Bool (Either Bool a) nested (Right (Right v)) = Right (Right v) - nested _ = Left True - -So if we come across + nested _ = Left True +We want the RHS of the first branch to be just the original argument. +The RHS of 'nested' will look like case x of r1 Right a -> case a of r2 Right b -> let v = Right b in Right v +Then: +* We create the ce_conAppMap [Right a :-> r1, Right b :-> r2]. +* When we encounter v = Right b, we'll drop the binding and extend + the substitution with [v :-> r2] +* But now when we see (Right v), we'll substitute to get (Right r2)...and + fail to find that in the ce_conAppMap! + +Solution: + +* When passing (case x of bndr { alts }), where 'x' is a variable, we + add [bndr :-> x] to the ce_bndrMap. In our example the ce_bndrMap will + be [r1 :-> x, r2 :-> a]. This is done in addTrivCaseBndr. + +* Before doing the /lookup/ in ce_conAppMap, we "normalise" the + arguments with the ce_bndrMap. In our example, we normalise + (Right r2) to (Right a), and then find it in the map. Normalisation + is done by normaliseConArgs. + +* Similarly before /inserting/ in ce_conAppMap, we normalise the arguments. + This is a bit more subtle. Suppose we have + case x of y + DEFAULT -> let a = Just y + let b = Just y + in ... + We'll have [y :-> x] in the ce_bndrMap. When looking up (Just y) in + the map, we'll normalise it to (Just x). So we'd better normalise + the (Just y) in the defn of 'a', before inserting it! + +* When inserting into cs_bndrMap, we must normalise that too! + case x of y + DEFAULT -> case y of z + DEFAULT -> ... + We want the cs_bndrMap to be [y :-> x, z :-> x]! + Hence the call to normaliseId in addTrivCaseBinder. + +All this is a bit tricky. Why does it not occur for the Core version +of CSE? See Note [CSE for bindings] in GHC.Core.Opt.CSE. The reason +is this: in Core CSE we augment the /main substitution/ with [y :-> x] +etc, so as a side consequence we transform + case x of y ===> case x of y + pat -> ...y... pat -> ...x... +That is, the /exact reverse/ of the binder-swap transformation done by +the occurrence analyser. However, it's easy for CSE to do on-the-fly, +and it completely solves the above tricky problem, using only two maps: +the main reverse-map, and the substitution. The occurrence analyser +puts it back the way it should be, the next time it runs. + +However in STG there is no occurrence analyser, and we don't want to +require another pass. So the ce_bndrMap is a little swizzle that we +apply just when manipulating the ce_conAppMap, but that does not +affect the output program. -we first replace v with r2. Next we want to replace Right r2 with r1. But the -ce_conAppMap contains Right a! - -Therefore, we add r1 ↦ x to ce_bndrMap when analysing the outer case, and use -this substitution before looking Right r2 up in ce_conAppMap, and everything -works out. Note [Free variables of an StgClosure] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs index 5a6560864d..f327d8f9f7 100644 --- a/compiler/GHC/Tc/Gen/Sig.hs +++ b/compiler/GHC/Tc/Gen/Sig.hs @@ -850,7 +850,7 @@ An imported Id may or may not have an unfolding. If not, we obviously can't specialise it here; indeed the desugar falls over (#18118). We used to test whether it had a user-specified INLINABLE pragma but, -because of Note [Worker-wrapper for INLINABLE functions] in +because of Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap, even an INLINABLE function may end up with a wrapper that has no pragma, just an unfolding (#19246). So now we just test whether the function has an unfolding. diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs index 94d454055e..40cdf54d12 100644 --- a/compiler/GHC/Tc/Types.hs +++ b/compiler/GHC/Tc/Types.hs @@ -579,7 +579,10 @@ data TcGblEnv tcg_complete_matches :: !CompleteMatches, -- ^ Tracking indices for cost centre annotations - tcg_cc_st :: TcRef CostCentreState + tcg_cc_st :: TcRef CostCentreState, + + tcg_next_wrapper_num :: TcRef (ModuleEnv Int) + -- ^ See Note [Generating fresh names for FFI wrappers] } -- NB: topModIdentity, not topModSemantic! diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs index 7ffd2f2f2c..cf0f1b706b 100644 --- a/compiler/GHC/Tc/Utils/Env.hs +++ b/compiler/GHC/Tc/Utils/Env.hs @@ -1086,7 +1086,8 @@ mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM mkStableIdFromString str sig_ty loc occ_wrapper = do uniq <- newUnique mod <- getModule - name <- mkWrapperName "stable" str + nextWrapperNum <- tcg_next_wrapper_num <$> getGblEnv + name <- mkWrapperName nextWrapperNum "stable" str let occ = mkVarOccFS name :: OccName gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name id = mkExportedVanillaId gnm sig_ty :: Id @@ -1095,14 +1096,14 @@ mkStableIdFromString str sig_ty loc occ_wrapper = do mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId mkStableIdFromName nm = mkStableIdFromString (getOccString nm) -mkWrapperName :: (MonadIO m, HasDynFlags m, HasModule m) - => String -> String -> m FastString -mkWrapperName what nameBase - = do dflags <- getDynFlags - thisMod <- getModule - let -- Note [Generating fresh names for ccall wrapper] - wrapperRef = nextWrapperNum dflags - pkg = unitString (moduleUnit thisMod) +mkWrapperName :: (MonadIO m, HasModule m) + => IORef (ModuleEnv Int) -> String -> String -> m FastString +-- ^ @mkWrapperName ref what nameBase@ +-- +-- See Note [Generating fresh names for ccall wrapper] for @ref@'s purpose. +mkWrapperName wrapperRef what nameBase + = do thisMod <- getModule + let pkg = unitString (moduleUnit thisMod) mod = moduleNameString (moduleName thisMod) wrapperNum <- liftIO $ atomicModifyIORef' wrapperRef $ \mod_env -> let num = lookupWithDefaultModuleEnv mod_env 0 thisMod diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index fb613c8f8d..5568e34b75 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -260,6 +260,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this th_state_var <- newIORef Map.empty ; th_remote_state_var <- newIORef Nothing ; th_docs_var <- newIORef Map.empty ; + next_wrapper_num <- newIORef emptyModuleEnv ; let { -- bangs to avoid leaking the env (#19356) !dflags = hsc_dflags hsc_env ; @@ -347,7 +348,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this tcg_top_loc = loc, tcg_static_wc = static_wc_var, tcg_complete_matches = [], - tcg_cc_st = cc_st_var + tcg_cc_st = cc_st_var, + tcg_next_wrapper_num = next_wrapper_num } ; } ; diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index 77c436c912..ce88ddeade 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -131,7 +131,7 @@ returnL :: a -> CvtM (Located a) returnL x = CvtM (\_ loc -> Right (loc, L loc x)) -- returnLA :: a -> CvtM (LocatedA a) -returnLA :: e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn' ann)) e) +returnLA :: e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e) returnLA x = CvtM (\_ loc -> Right (loc, L (noAnnSrcSpan loc) x)) returnJustLA :: a -> CvtM (Maybe (LocatedA a)) diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs index 84e5a9ac67..c4e25a1a47 100644 --- a/compiler/GHC/Types/Demand.hs +++ b/compiler/GHC/Types/Demand.hs @@ -719,7 +719,7 @@ the latter, for a regrettable-subtle reason. Consider g h p2@(_,_) = h p We want to unbox @p1@ of @f@, but not @p2@ of @g@, because @g@ only uses @p2@ boxed and we'd have to rebox. So we give @p1@ demand LP(L,L) and @p2@ -demand @L@ to inform 'GHC.Core.Opt.WorkWrap.Utils.wantToUnbox', which will +demand @L@ to inform 'GHC.Core.Opt.WorkWrap.Utils.wantToUnboxArg', which will say "unbox" for @p1@ and "don't unbox" for @p2@. So the solution is: don't aggressively collapse @Prod [topDmd, topDmd]@ to diff --git a/configure.ac b/configure.ac index 1f524bdf54..013f21f3ca 100644 --- a/configure.ac +++ b/configure.ac @@ -321,7 +321,7 @@ AC_MSG_CHECKING(whether target supports tables next to code) case "$Unregisterised" in NO) case "$TargetArch" in - ia64|powerpc64|powerpc64le|s390x|riscv64) + ia64|powerpc64|powerpc64le|s390x) TablesNextToCodeDefault=NO AC_MSG_RESULT([no]) ;; @@ -1219,6 +1219,8 @@ dnl ~~~~~~~~~~~~~~~~~~~~ dnl The portability situation here is complicated: dnl dnl * FreeBSD supports pthread_set_name_np in <pthread_np.h> +dnl and (if not _POSIX_SOURCE) pthread_setname_np() in <pthread.h> +dnl because of the conditional visibility, we prefer the former. dnl * glibc supports pthread_setname_np dnl * Darwin supports pthread_setname_np but does not take a dnl pthread_t argument. @@ -1270,7 +1272,7 @@ AC_LINK_IFELSE([ [[ #include <pthread_np.h> ]], - [[pthread_setname_np(pthread_self(), "name");]] + [[pthread_set_name_np(pthread_self(), "name");]] )], [ AC_MSG_RESULT(yes) diff --git a/docs/users_guide/exts/control.rst b/docs/users_guide/exts/control.rst index a94def72b5..1a5431f526 100644 --- a/docs/users_guide/exts/control.rst +++ b/docs/users_guide/exts/control.rst @@ -18,7 +18,7 @@ Language extensions can be controlled (i.e. allowed or not) in two ways: ``{-# LANGUAGE TemplateHaskell #-}`` (see :ref:`language-pragma`). .. extension:: GHC2021 - :shortdesc: Use GHC’s set of default languages from 2021 + :shortdesc: Use GHC’s set of default language extensions from 2021 GHC blesses a number of extensions, beyond Haskell 2010, to be suitable to turned on by default. These extensions are considered to be stable and @@ -29,20 +29,17 @@ Language extensions can be controlled (i.e. allowed or not) in two ways: ``GHC20xx`` by default, users are advised to declare the language set explicitly with ``-XGHC2021``. + Note that, because GHC2021 includes a number of non-standardized + extensions, the stability guarantees it provides are not quite as strong as + those provided by, e.g., :extension:`Haskell2010`. While GHC does take + pains to avoid changing the semantics of these extensions, changes may + still happen (e.g. the simplified subsumption change introduced in GHC 9.0 + which caused GHC to reject some programs using :extension:`RankNTypes`). The ``GHC2021`` language set comprises the following extensions: .. hlist:: - * :extension:`ImplicitPrelude` - * :extension:`StarIsType` - * :extension:`MonomorphismRestriction` - * :extension:`TraditionalRecordSyntax` - * :extension:`EmptyDataDecls` - * :extension:`ForeignFunctionInterface` - * :extension:`PatternGuards` - * :extension:`DoAndIfThenElse` - * :extension:`RelaxedPolyRec` * :extension:`BangPatterns` * :extension:`BinaryLiterals` * :extension:`ConstrainedClassMethods` @@ -53,28 +50,38 @@ Language extensions can be controlled (i.e. allowed or not) in two ways: * :extension:`DeriveGeneric` * :extension:`DeriveLift` * :extension:`DeriveTraversable` + * :extension:`DoAndIfThenElse` * :extension:`EmptyCase` + * :extension:`EmptyDataDecls` * :extension:`EmptyDataDeriving` * :extension:`ExistentialQuantification` * :extension:`ExplicitForAll` + * :extension:`FieldSelectors` * :extension:`FlexibleContexts` * :extension:`FlexibleInstances` + * :extension:`ForeignFunctionInterface` * :extension:`GADTSyntax` * :extension:`GeneralisedNewtypeDeriving` * :extension:`HexFloatLiterals` + * :extension:`ImplicitPrelude` * :extension:`ImportQualifiedPost` * :extension:`InstanceSigs` * :extension:`KindSignatures` + * :extension:`MonomorphismRestriction` * :extension:`MultiParamTypeClasses` * :extension:`NamedFieldPuns` * :extension:`NamedWildCards` * :extension:`NumericUnderscores` + * :extension:`PatternGuards` * :extension:`PolyKinds` * :extension:`PostfixOperators` * :extension:`RankNTypes` + * :extension:`RelaxedPolyRec` * :extension:`ScopedTypeVariables` * :extension:`StandaloneDeriving` * :extension:`StandaloneKindSignatures` + * :extension:`StarIsType` + * :extension:`TraditionalRecordSyntax` * :extension:`TupleSections` * :extension:`TypeApplications` * :extension:`TypeOperators` @@ -89,18 +96,18 @@ Language extensions can be controlled (i.e. allowed or not) in two ways: .. hlist:: - * :extension:`ImplicitPrelude` - * :extension:`StarIsType` * :extension:`CUSKs` - * :extension:`MonomorphismRestriction` * :extension:`DatatypeContexts` - * :extension:`TraditionalRecordSyntax` - * :extension:`FieldSelectors` + * :extension:`DoAndIfThenElse` * :extension:`EmptyDataDecls` + * :extension:`FieldSelectors` * :extension:`ForeignFunctionInterface` + * :extension:`ImplicitPrelude` + * :extension:`MonomorphismRestriction` * :extension:`PatternGuards` - * :extension:`DoAndIfThenElse` * :extension:`RelaxedPolyRec` + * :extension:`StarIsType` + * :extension:`TraditionalRecordSyntax` .. extension:: Haskell98 @@ -111,15 +118,15 @@ Language extensions can be controlled (i.e. allowed or not) in two ways: .. hlist:: - * :extension:`ImplicitPrelude` - * :extension:`StarIsType` * :extension:`CUSKs` - * :extension:`MonomorphismRestriction` - * :extension:`NPlusKPatterns` * :extension:`DatatypeContexts` - * :extension:`TraditionalRecordSyntax` * :extension:`FieldSelectors` + * :extension:`ImplicitPrelude` + * :extension:`MonomorphismRestriction` + * :extension:`NPlusKPatterns` * :extension:`NondecreasingIndentation` + * :extension:`StarIsType` + * :extension:`TraditionalRecordSyntax` diff --git a/docs/users_guide/packages.rst b/docs/users_guide/packages.rst index 837a444a74..ff6953ac8c 100644 --- a/docs/users_guide/packages.rst +++ b/docs/users_guide/packages.rst @@ -536,6 +536,10 @@ or ``ghci`` that are local to a shell session or to some file system location. They are intended to be managed by build/package tools, to enable ``ghc`` and ``ghci`` to automatically use an environment created by the tool. +In the case of ``ghci``, the environment file will be read once, during +initialisation. If the file changes then you have to restart GHCi to reflect +the updated file. + The file contains package IDs and optionally package databases, one directive per line: diff --git a/docs/users_guide/using-optimisation.rst b/docs/users_guide/using-optimisation.rst index 2722a285df..523b0a7e66 100644 --- a/docs/users_guide/using-optimisation.rst +++ b/docs/users_guide/using-optimisation.rst @@ -488,7 +488,7 @@ by saying ``-fno-wombat``. :default: off - Worker-wrapper removes unused arguments, but usually we do not + Worker/wrapper removes unused arguments, but usually we do not remove them all, lest it turn a function closure into a thunk, thereby perhaps creating a space leak and/or disrupting inlining. This flag allows worker/wrapper to remove *all* value lambdas. diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index 80700e9caf..c53f6771b5 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -3029,13 +3029,17 @@ setOptions wds = -- then, dynamic flags when (not (null minus_opts)) $ newDynFlags False minus_opts +-- | newDynFlags will *not* read package environment files, therefore we +-- use 'parseDynamicFlagsCmdLine' rather than 'parseDynamicFlags'. This +-- function is called very often and results in repeatedly loading +-- environment files (see #19650) newDynFlags :: GhciMonad m => Bool -> [String] -> m () newDynFlags interactive_only minus_opts = do let lopts = map noLoc minus_opts logger <- getLogger idflags0 <- GHC.getInteractiveDynFlags - (idflags1, leftovers, warns) <- GHC.parseDynamicFlags logger idflags0 lopts + (idflags1, leftovers, warns) <- DynFlags.parseDynamicFlagsCmdLine idflags0 lopts liftIO $ handleFlagWarnings logger idflags1 warns when (not $ null leftovers) @@ -3051,7 +3055,7 @@ newDynFlags interactive_only minus_opts = do dflags0 <- getDynFlags when (not interactive_only) $ do - (dflags1, _, _) <- liftIO $ GHC.parseDynamicFlags logger dflags0 lopts + (dflags1, _, _) <- liftIO $ DynFlags.parseDynamicFlagsCmdLine dflags0 lopts must_reload <- GHC.setProgramDynFlags dflags1 -- if the package flags changed, reset the context and link diff --git a/libraries/base/Data/Functor/Classes.hs b/libraries/base/Data/Functor/Classes.hs index 6a0d008982..d672c340d7 100644 --- a/libraries/base/Data/Functor/Classes.hs +++ b/libraries/base/Data/Functor/Classes.hs @@ -848,11 +848,13 @@ instance Eq1 Complex where -- [(2 % 3 :+ 3 % 4,"")] -- instance Read1 Complex where - liftReadPrec rp _ = parens $ prec 9 $ do + liftReadPrec rp _ = parens $ prec complexPrec $ do x <- step rp expectP (Symbol ":+") y <- step rp return (x :+ y) + where + complexPrec = 6 liftReadListPrec = liftReadListPrecDefault liftReadList = liftReadListDefault @@ -863,8 +865,10 @@ instance Read1 Complex where -- "2 :+ 3" -- instance Show1 Complex where - liftShowsPrec sp _ d (x :+ y) = showParen (d >= 10) $ - sp 10 x . showString " :+ " . sp 10 y + liftShowsPrec sp _ d (x :+ y) = showParen (d > complexPrec) $ + sp (complexPrec+1) x . showString " :+ " . sp (complexPrec+1) y + where + complexPrec = 6 -- Building blocks diff --git a/libraries/base/tests/T19719.hs b/libraries/base/tests/T19719.hs new file mode 100644 index 0000000000..613f92ad6c --- /dev/null +++ b/libraries/base/tests/T19719.hs @@ -0,0 +1,26 @@ +module Main (main) where + +import Data.Complex (Complex(..)) +import Data.Functor.Classes (readPrec1, showsPrec1) +import Text.ParserCombinators.ReadPrec (readPrec_to_S) +import Text.Read (Read(..)) + +comp :: Complex Int +comp = 1 :+ 1 + +compareInstances :: Int -> IO () +compareInstances p = do + let precBanner = " (at precedence " ++ show p ++ ")" + putStrLn $ "Read vs. Read1" ++ precBanner + print (readPrec_to_S readPrec p "1 :+ 1" :: [(Complex Int, String)]) + print (readPrec_to_S readPrec1 p "1 :+ 1" :: [(Complex Int, String)]) + putStrLn "" + putStrLn $ "Show vs. Show1" ++ precBanner + putStrLn $ showsPrec p comp "" + putStrLn $ showsPrec1 p comp "" + putStrLn "" + +main :: IO () +main = do + compareInstances 6 + compareInstances 7 diff --git a/libraries/base/tests/T19719.stdout b/libraries/base/tests/T19719.stdout new file mode 100644 index 0000000000..8f59bd40f0 --- /dev/null +++ b/libraries/base/tests/T19719.stdout @@ -0,0 +1,16 @@ +Read vs. Read1 (at precedence 6) +[(1 :+ 1,"")] +[(1 :+ 1,"")] + +Show vs. Show1 (at precedence 6) +1 :+ 1 +1 :+ 1 + +Read vs. Read1 (at precedence 7) +[] +[] + +Show vs. Show1 (at precedence 7) +(1 :+ 1) +(1 :+ 1) + diff --git a/libraries/base/tests/all.T b/libraries/base/tests/all.T index b02d77ef11..7ea69949e2 100644 --- a/libraries/base/tests/all.T +++ b/libraries/base/tests/all.T @@ -263,3 +263,4 @@ test('T16643', normal, compile_and_run, ['']) test('clamp', normal, compile_and_run, ['']) test('T18642', extra_run_opts('+RTS -T -RTS'), compile_and_run, ['-O2']) test('T19288', exit_code(1), compile_and_run, ['']) +test('T19719', normal, compile_and_run, ['']) diff --git a/libraries/ghci/GHCi/InfoTable.hsc b/libraries/ghci/GHCi/InfoTable.hsc index fce2c653f2..c5dd4f0db8 100644 --- a/libraries/ghci/GHCi/InfoTable.hsc +++ b/libraries/ghci/GHCi/InfoTable.hsc @@ -241,6 +241,15 @@ mkJumpToAddr a = case hostPlatformArch of 0xC0, 0x19, byte3 w64, byte2 w64, byte1 w64, byte0 w64, 0x07, 0xF1 ] + ArchRISCV64 -> pure $ + let w64 = fromIntegral (funPtrToInt a) :: Word64 + in Right [ 0x00000297 -- auipc t0,0 + , 0x01053283 -- ld t0,16(t0) + , 0x00028067 -- jr t0 + , 0x00000013 -- nop + , fromIntegral w64 + , fromIntegral (w64 `shiftR` 32) ] + arch -> -- The arch isn't supported. You either need to add your architecture as a -- distinct case, or use non-TABLES_NEXT_TO_CODE mode. diff --git a/rts/LinkerInternals.h b/rts/LinkerInternals.h index f81b0d2f45..e1da899c89 100644 --- a/rts/LinkerInternals.h +++ b/rts/LinkerInternals.h @@ -195,7 +195,8 @@ typedef struct { } jumpIsland; #elif defined(x86_64_HOST_ARCH) uint64_t addr; - uint8_t jumpIsland[6]; + // See Note [TLSGD relocation] in elf_tlsgd.c + uint8_t jumpIsland[8]; #elif defined(arm_HOST_ARCH) uint8_t jumpIsland[16]; #endif @@ -400,6 +401,10 @@ int ghciInsertSymbolTable( * dependent to the owner of the symbol. */ SymbolAddr* lookupDependentSymbol (SymbolName* lbl, ObjectCode *dependent); +/* Perform TLSGD symbol lookup returning the address of the resulting GOT entry, + * which in this case holds the module id and the symbol offset. */ +StgInt64 lookupTlsgdSymbol(const char *, unsigned long, ObjectCode *); + extern StrHashTable *symhash; pathchar* diff --git a/rts/linker/Elf.c b/rts/linker/Elf.c index d34b6e6e50..84cb72bd6b 100644 --- a/rts/linker/Elf.c +++ b/rts/linker/Elf.c @@ -1528,10 +1528,41 @@ do_Elf_Rela_relocations ( ObjectCode* oc, char* ehdrC, S = 0; } else { Elf_Sym sym = stab[ELF_R_SYM(info)]; - /* First see if it is a local symbol. */ - if (ELF_ST_BIND(sym.st_info) == STB_LOCAL) { - /* Yes, so we can get the address directly from the ELF symbol - table. */ + if (ELF_R_TYPE(info) == COMPAT_R_X86_64_TLSGD) { + /* + * No support for TLSGD variables *defined* by the object, + * only references to *external* TLS variables in already + * loaded shared objects (the executable, libc, ...) are + * supported. See Note [TLSGD relocation] in elf_tlsgd.c. + */ + symbol = sym.st_name == 0 ? "(noname)" : strtab+sym.st_name; + if (ELF_ST_BIND(sym.st_info) == STB_LOCAL + || sym.st_value != 0 || sym.st_name == 0) { + errorBelch("%s: unsupported internal ELF TLSGD relocation for" + " symbol `%s'", oc->fileName, symbol); + return 0; + } +#if defined(x86_64_HOST_ARCH) && defined(freebsd_HOST_OS) + S = lookupTlsgdSymbol(symbol, ELF_R_SYM(info), oc); +#else + errorBelch("%s: ELF TLSGD relocation for symbol `%s'" + " not supported on the target platform", + oc->fileName, symbol); + return 0; +#endif + } else if (ELF_ST_BIND(sym.st_info) == STB_LOCAL) { + /* + * For local symbols, we can get the address directly from the ELF + * symbol table. + * + * XXX: Is STB_LOCAL the right test here? Should we instead be + * checking whether the symbol is *defined* by the current object? + * Defined globals also need relocation. Perhaps the point is that + * conflicts are resolved in favour of any prior definition, so we + * must look at the accumulated symbol table instead (which has + * already been updated with our global symbols by the time we get + * here). + */ symbol = sym.st_name==0 ? "(noname)" : strtab+sym.st_name; /* See Note [Many ELF Sections] */ Elf_Word secno = sym.st_shndx; @@ -1543,7 +1574,7 @@ do_Elf_Rela_relocations ( ObjectCode* oc, char* ehdrC, S = (Elf_Addr)oc->sections[secno].start + stab[ELF_R_SYM(info)].st_value; } else { - /* No, so look up the name in our global table. */ + /* If not local, look up the name in our global table. */ symbol = strtab + sym.st_name; S_tmp = lookupDependentSymbol( symbol, oc ); S = (Elf_Addr)S_tmp; @@ -1766,6 +1797,19 @@ do_Elf_Rela_relocations ( ObjectCode* oc, char* ehdrC, memcpy((void*)P, &payload, sizeof(payload)); break; } + case COMPAT_R_X86_64_TLSGD: + { + StgInt64 off = S + A - P; + if (off != (Elf64_Sword)off) { + barf( + "COMPAT_R_X86_64_TLSGD relocation out of range: " + "%s = %" PRIx64 " in %s.", + symbol, off, oc->fileName); + } + Elf64_Sword payload = off; + memcpy((void*)P, &payload, sizeof(payload)); + break; + } #if defined(dragonfly_HOST_OS) case COMPAT_R_X86_64_GOTTPOFF: { diff --git a/rts/linker/SymbolExtras.c b/rts/linker/SymbolExtras.c index f5147f8036..ddb58e4a4e 100644 --- a/rts/linker/SymbolExtras.c +++ b/rts/linker/SymbolExtras.c @@ -182,9 +182,11 @@ SymbolExtra* makeSymbolExtra( ObjectCode const* oc, #if defined(x86_64_HOST_ARCH) // jmp *-14(%rip) // 0xFF 25 is opcode + ModRM of near absolute indirect jump - static uint8_t jmp[] = { 0xFF, 0x25, 0xF2, 0xFF, 0xFF, 0xFF }; + // Two bytes trailing padding, needed for TLSGD GOT entries + // See Note [TLSGD relocation] in elf_tlsgd.c + static uint8_t jmp[] = { 0xFF, 0x25, 0xF2, 0xFF, 0xFF, 0xFF, 0x00, 0x00 }; extra->addr = target; - memcpy(extra->jumpIsland, jmp, 6); + memcpy(extra->jumpIsland, jmp, 8); #endif /* x86_64_HOST_ARCH */ return extra; diff --git a/rts/linker/elf_tlsgd.c b/rts/linker/elf_tlsgd.c new file mode 100644 index 0000000000..ec42e29ac6 --- /dev/null +++ b/rts/linker/elf_tlsgd.c @@ -0,0 +1,249 @@ +#include "Rts.h" + +#if defined(x86_64_HOST_ARCH) && defined(freebsd_HOST_OS) + +/* + * Note [TLSGD relocation] + * + * Quick background: FreeBSD's <ctype.h> is poisoned with static inline code + * that gets compiled into every program that uses functions like isdigit(3). + * When compiled "-c -fpic" for inclusion in position-independent ".a" files + * that are used in GHCi and HLS to load dependent packages at runtime, code + * that uses <ctype.h> in some FFI ends up with previously unsupported + * thread-specific variable (TLSGD) relocations. This module narrowly addresses + * the issue for FreeBSD, where one often ends up using thread-local storage + * without meaning to. + * + * In the "General Dynamic" Thread-Local-Storage (TLSGD) model, relocations need + * an offset into a block of thread-local data associated with a particular + * module in which the given thread-local variable is defined. Such blocks are + * not used directly, since after all, the variables are thread-specific. + * Rather, each module's initialized thread locals and uninitialised (zeroed) + * thread-locals are used to initialise a corresponding block of data in each + * thread, possibly on first use by a thread of a variable from a given module. + * + * A thread that needs the address of a particular TLS variable needs to pass + * the module id and offset to __tls_get_addr() (provided by the ELF runtime + * linker ld.so, a.k.a. the RTLD, which also manages the loading and unloading + * of modules, and dynamic creation of the backing storage for each thread's + * dynamic thread-local-storage vector (dtv). + * + * The data to pass to __tls_get_addr() is found as two consecutive 64-bit + * values in the global offset table (GOT) of the object being relocated. + * (There are therefore many GOT tables, what's global is the addresses they + * point to, which are often outside the current object, not the tables + * themselves). + * + * The module id and offset are not known at compile time, and require + * relocation with assistance from the RTLD, because only the RTLD knows the + * logical module number for each loaded object (the main executable, and any + * shared libraries, such as libc). Fortunately, modern RTLDs provide an + * iterator for the currently loaded modules of a program, which exposes + * the associated module id and ELF section headers of each loaded object. + * (For static executables, this is instead handled by the C library). + * + * The iterator in question is dl_iterate_phdr(3). It repeatedly invokes + * the provided callback for each loaded module until the callback returns + * a non-zero value indicating that it has found what it was looking for + * and does not need to be called with any further modules. + * + * The "dlpi_info" structure provided to the callback contains the module + * id and a reference to the ELF program header list. In the program header + * list the "dynamic" section contains a number of subsections, which include + * the symbol table, the string table and either or both the sysv or GNU-style + * symbol hash table. + * + * The size of the symbol table is not directly available, so linear search + * through the symbol table is not only inefficient, but in fact not really + * possible, since we don't reliably know where the table ends. However, the + * hash tables (sysv and/or GNU) do have clear bounds, and substantially speed + * up symbol lookup, so we need to have code to use these tables. For now, + * only the sysv table is supported, but it should be easy to also support the + * GNU table (which could be the only present). On FreeBSD it is rumoured (or + * least anecdotally observed) that the tool chains ensure that the sysv table + * is always present. + * + * Thus armed with the symbol, string and hash table for a module, we can use + * our wanted symbol's hash to quickly find the relevant hash bucket, and from + * there traverse the list of symbols that share that hash, checking that + * whether the name is in fact an exact match. + * + * Note that the name we want may also appear as an undefined entry in the + * symbol tables of other modules that also reference it as an external symbol. + * Thus the module we're looking for is the one where the symbol's st_value is + * non-zero (indicating that it is actually defined in that module). + * + * Since we're looking for a TLS variable, we just in case also check the type + * and avoid erroneous bindings to some other sort of symbol. + * + * Once the right module is found, we need to push two values into a new slot + * in the GOT. This is done via the makeSymbolExtra() function of the GHC RTS. + * Our GOT entries must therefore be wide enough to hold two 64-bit values, but + * previously their X86_64 incarnation was only 14 bytes wide. It has now been + * expanded to 16 bytes, by adding two padding bytes to the jumpIsland slot + * that follows the `addr` field field of the original GOT entry. We store the + * module id in the `addr` field and the symbol's offset in the expanded + * jumpIsland field. The address `S` of the start of the new GOT entry is + * then adjusted to form the relative address `S + A - P` which is stored at the + * relocation address `P`. + * + * The magic additional offsets `0x8000` and `0x800` for MIPS, ... and RISC-V, + * were suggested by Fangrui Song (a.k.a. @MaskRay) in a comment on the ticket + * discussing the motivating FreeBSD issue: + * <https://gitlab.haskell.org/ghc/ghc/-/issues/19086#note_347076>. + * His blog at <https://maskray.me/blog/2021-02-14-all-about-thread-local-storage> + * may shed more light on these. + * + * Finally, the bad news. This code only works when the target TLS variable is + * defined by a preloaded shared object (.SO) that is known to the RTLD, has a + * module id, and TLS data and bss segments from which the RTLD initialises + * (perhaps lazily just-in-time) the per-thread TLS segments. It is not + * presently possible to support TLS variables from runtime loaded ".o" files, + * These are not loaded via the RTLD, and don't get a new module id, and + * __tls_get_addr() cannot return an appropriate thread-specific address for + * these. + * + * The best solution is probably to deprecate runtime loading of ".o" files, + * all runtime loaded objects should be shared objects, loaded via dlopen(), + * in which case the RTLD will take of all the TLS relocation details! + * Otherwise, packages with FFI code that uses the _Thread_local storage class + * will not be runtime loadable in GHCi, Haskell-language-server, and similar + * programs that use the GHC RTS runtime linker. As the popularity of such + * variables increases, we'll need have a more comprehensive approach to dealing + * with them, not limited to just "external references" as supported here. + * + * A much more complex approach would be to filter calls to __tls_get_addr(), + * using GHC-specific code to allocate per-thread storage for TLS variables in + * code loaded via ".o" files, delegating just external TLS variables to the + * RTLD. It is far from clear how to do that, and likely unwise to even think + * about going there. + */ + +#include "linker/Elf.h" +#include "linker/SymbolExtras.h" +#include <link.h> +#include <string.h> + +/* + * Though for now we only get here for X86_64, also handle some other CPUs. + */ +#if defined(__mips__) || defined(__powerpc__) || defined(__powerpc64__) +#define OFFSUB 0x8000 +#elif defined(__riscv__) +#define OFFSUB 0x800 +#else +#define OFFSUB 0x0 +#endif + +static unsigned long +elfhash(const unsigned char *name) +{ + unsigned long h = 0, g; + + while (*name) + { + h = (h << 4) + *name++; + if ((g = h & 0xf0000000) != 0) + h ^= g >> 24; + h &= ~g; + } + return h; +} + +typedef struct tls_sym { + ObjectCode *tls_sym_object; + const char *tls_sym_name; + unsigned long tls_sym_indx; + unsigned long tls_sym_hash; + StgInt64 tls_sym_reloc; +} tls_sym; + +typedef struct dl_phdr_info dlpi; + +static int +find_tls_sym(dlpi *info, size_t sz __attribute__((unused)), void *data) +{ + tls_sym *wanted = (tls_sym *)data; + const Elf_Addr base = info->dlpi_addr; + const Elf_Dyn *dyn = NULL; + const Elf_Sym *dynsym = NULL; + const Elf_Word *dynhash = 0; + const char *dynstr = NULL; + + for (size_t i = 0; i < info->dlpi_phnum; i++) { + const Elf_Phdr *phdr = &info->dlpi_phdr[i]; + + if (phdr->p_type == PT_DYNAMIC) { + dyn = (const Elf_Dyn *)(base + phdr->p_vaddr); + break; + } + } + if (dyn == NULL) + return 0; + + for (size_t i = 0; dyn[i].d_tag != DT_NULL; ++i) + switch (dyn[i].d_tag) { + case DT_SYMTAB: + dynsym = (const Elf_Sym *)(base + dyn[i].d_un.d_val); + break; + case DT_STRTAB: + dynstr = (const char *)(base + dyn[i].d_un.d_val); + break; + case DT_HASH: + dynhash = (const Elf_Word *)(base + dyn[i].d_un.d_val); + break; + default: + break; + } + + if (dynsym == NULL || dynstr == NULL || dynhash == NULL) + return 0; + + unsigned long nbucket = (unsigned long)dynhash[0]; + // unsigned long nchain = (unsigned long)dynhash[1]; + const Elf_Word *bucket = &dynhash[2]; + const Elf_Word *chain = &dynhash[2+nbucket]; + unsigned long h = wanted->tls_sym_hash % nbucket; + + for (unsigned long i = bucket[h]; i != STN_UNDEF; i = chain[i]) { + const Elf_Sym *sym = dynsym+i; + const char *symname = dynstr + sym->st_name; + + /* Ignore undefined or non-TLS symbols */ + if (sym->st_value == 0 || ELF_ST_TYPE(sym->st_info) != STT_TLS) + continue; + + if (strcmp(symname, wanted->tls_sym_name) == 0) { + unsigned long target = sym->st_value - OFFSUB; + /* Store the module id as GOT[0] in a new GOT entry */ + SymbolExtra *extra = + makeSymbolExtra(wanted->tls_sym_object, + wanted->tls_sym_indx, + info->dlpi_tls_modid); + /* Copy the target address to GOT[1] (a.k.a. jumpIsland) */ + memcpy(extra->jumpIsland, &target, sizeof(target)); + wanted->tls_sym_reloc = (StgInt64) extra; + /* Signal success, no more modules will be tried */ + return 1; + } + } + /* Try the next module if any */ + return 0; +} + +StgInt64 +lookupTlsgdSymbol(const char *symbol, unsigned long symnum, ObjectCode *oc) +{ + tls_sym t; + + t.tls_sym_object = oc; + t.tls_sym_name = symbol; + t.tls_sym_indx = symnum; + t.tls_sym_hash = elfhash((unsigned char *)symbol); + t.tls_sym_reloc = 0; + + dl_iterate_phdr(find_tls_sym, &t); + + return t.tls_sym_reloc; +} +#endif diff --git a/rts/posix/itimer/Pthread.c b/rts/posix/itimer/Pthread.c index 82379b9172..7b968f28f0 100644 --- a/rts/posix/itimer/Pthread.c +++ b/rts/posix/itimer/Pthread.c @@ -63,6 +63,9 @@ #include <string.h> #include <pthread.h> +#if defined(HAVE_PTHREAD_NP_H) +#include <pthread_np.h> +#endif #include <unistd.h> #include <fcntl.h> @@ -168,6 +171,11 @@ initTicker (Time interval, TickProc handle_tick) itimer_interval = interval; stopped = false; exited = false; +#if defined(HAVE_SIGNAL_H) + sigset_t mask, omask; + int sigret; +#endif + int ret; initCondition(&start_cond); initMutex(&mutex); @@ -175,10 +183,35 @@ initTicker (Time interval, TickProc handle_tick) /* * We can't use the RTS's createOSThread here as we need to remain attached * to the thread we create so we can later join to it if requested + * + * On FreeBSD 12.2 pthread_set_name_np() is unconditionally declared in + * <pthread_np.h>, while pthread_setname_np() is conditionally declared in + * <pthread.h> when _POSIX_SOURCE is not defined, but we're including + * <PosixSource.h>, so must use pthread_set_name_np() instead. See similar + * code in "rts/posix/OSThreads.c". + * + * Create the thread with all blockable signals blocked, leaving signal + * handling to the main and/or other threads. This is especially useful in + * the non-threaded runtime, where applications might expect sigprocmask(2) + * to effectively block signals. */ - if (! pthread_create(&thread, NULL, itimer_thread_func, (void*)handle_tick)) { -#if defined(HAVE_PTHREAD_SETNAME_NP) +#if defined(HAVE_SIGNAL_H) + sigfillset(&mask); + sigret = pthread_sigmask(SIG_SETMASK, &mask, &omask); +#endif + ret = pthread_create(&thread, NULL, itimer_thread_func, (void*)handle_tick); +#if defined(HAVE_SIGNAL_H) + if (sigret == 0) + pthread_sigmask(SIG_SETMASK, &omask, NULL); +#endif + + if (ret == 0) { +#if defined(HAVE_PTHREAD_SET_NAME_NP) + pthread_set_name_np(thread, "ghc_ticker"); +#elif defined(HAVE_PTHREAD_SETNAME_NP) pthread_setname_np(thread, "ghc_ticker"); +#elif defined(HAVE_PTHREAD_SETNAME_NP_DARWIN) + pthread_setname_np("ghc_ticker"); #endif } else { barf("Itimer: Failed to spawn thread: %s", strerror(errno)); diff --git a/rts/rts.cabal.in b/rts/rts.cabal.in index 6e1de4a4d5..872a9e3493 100644 --- a/rts/rts.cabal.in +++ b/rts/rts.cabal.in @@ -508,6 +508,7 @@ library linker/elf_plt_arm.c linker/elf_reloc.c linker/elf_reloc_aarch64.c + linker/elf_tlsgd.c linker/elf_util.c sm/BlockAlloc.c sm/CNF.c diff --git a/testsuite/mk/boilerplate.mk b/testsuite/mk/boilerplate.mk index 41ba2542a6..a2fb56d1ba 100644 --- a/testsuite/mk/boilerplate.mk +++ b/testsuite/mk/boilerplate.mk @@ -291,4 +291,9 @@ DARWIN = YES else DARWIN = NO endif +ifeq "$(HostOS)" "freebsd" +FREEBSD = YES +else +FREEBSD = NO +endif diff --git a/testsuite/tests/cpranal/should_compile/T18109.hs b/testsuite/tests/cpranal/should_compile/T18109.hs new file mode 100644 index 0000000000..5c52a187c9 --- /dev/null +++ b/testsuite/tests/cpranal/should_compile/T18109.hs @@ -0,0 +1,25 @@ +{-# OPTIONS_GHC -O2 -fforce-recomp -dno-typeable-binds #-} + +-- | These are all examples where the CPR worker should not return an unboxed +-- singleton tuple of the field, but rather the single field directly. +-- This is OK if the field indeed terminates quickly; +-- see Note [No unboxed tuple for single, unlifted transit var] +module T18109 where + +data F = F (Int -> Int) + +f :: Int -> F +f n = F (+n) +{-# NOINLINE f #-} + +data T = T (Int, Int) + +g :: T -> T +g t@(T p) = p `seq` t +{-# NOINLINE g #-} + +data U = U ![Int] + +h :: Int -> U +h n = U [0..n] +{-# NOINLINE h #-} diff --git a/testsuite/tests/cpranal/should_compile/T18109.stderr b/testsuite/tests/cpranal/should_compile/T18109.stderr new file mode 100644 index 0000000000..ad92bdda17 --- /dev/null +++ b/testsuite/tests/cpranal/should_compile/T18109.stderr @@ -0,0 +1,51 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core = {terms: 78, types: 81, coercions: 0, joins: 0/1} + +-- RHS size: {terms: 6, types: 4, coercions: 0, joins: 0/0} +T18109.$WU :: [Int] %1 -> U +T18109.$WU = \ (dt_aDr :: [Int]) -> case dt_aDr of dt_X0 { __DEFAULT -> T18109.U dt_X0 } + +-- RHS size: {terms: 6, types: 12, coercions: 0, joins: 0/0} +T18109.$wg :: (Int, Int) -> (# (Int, Int) #) +T18109.$wg = \ (ww_sKr :: (Int, Int)) -> case ww_sKr of p_X2 { (ipv_sIU, ipv1_sIV) -> (# p_X2 #) } + +-- RHS size: {terms: 10, types: 13, coercions: 0, joins: 0/0} +g :: T -> T +g = \ (w_sKp :: T) -> case w_sKp of { T ww_sKr -> case T18109.$wg ww_sKr of { (# ww1_sKJ #) -> T18109.T ww1_sKJ } } + +-- RHS size: {terms: 6, types: 5, coercions: 0, joins: 0/0} +T18109.$wf :: Int -> (# Int -> Int #) +T18109.$wf = \ (w_sKw :: Int) -> (# \ (v_B2 :: Int) -> GHC.Num.$fNumInt_$c+ v_B2 w_sKw #) + +-- RHS size: {terms: 7, types: 7, coercions: 0, joins: 0/0} +f :: Int -> F +f = \ (w_sKw :: Int) -> case T18109.$wf w_sKw of { (# ww_sKL #) -> T18109.F ww_sKL } + +-- RHS size: {terms: 26, types: 10, coercions: 0, joins: 0/1} +T18109.$wh :: GHC.Prim.Int# -> [Int] +T18109.$wh + = \ (ww_sKE :: GHC.Prim.Int#) -> + case GHC.Prim.># 0# ww_sKE of { + __DEFAULT -> + letrec { + go3_aKm :: GHC.Prim.Int# -> [Int] + go3_aKm + = \ (x_aKn :: GHC.Prim.Int#) -> + GHC.Types.: + @Int + (GHC.Types.I# x_aKn) + (case GHC.Prim.==# x_aKn ww_sKE of { + __DEFAULT -> go3_aKm (GHC.Prim.+# x_aKn 1#); + 1# -> GHC.Types.[] @Int + }); } in + go3_aKm 0#; + 1# -> GHC.Types.[] @Int + } + +-- RHS size: {terms: 10, types: 5, coercions: 0, joins: 0/0} +h :: Int -> U +h = \ (w_sKC :: Int) -> case w_sKC of { GHC.Types.I# ww_sKE -> case T18109.$wh ww_sKE of ww1_sKN { __DEFAULT -> T18109.U ww1_sKN } } + + + diff --git a/testsuite/tests/cpranal/should_compile/T18401.hs b/testsuite/tests/cpranal/should_compile/T18401.hs new file mode 100644 index 0000000000..c850d9a7e0 --- /dev/null +++ b/testsuite/tests/cpranal/should_compile/T18401.hs @@ -0,0 +1,20 @@ +{-# OPTIONS_GHC -O2 -fforce-recomp -dno-typeable-binds #-} + +module T18401 where + +-- | A safe version of `init`. +-- @safeInit [] = Nothing@ +-- @safeInit xs = Just $ init xs@ +safeInit :: [a] -> Maybe [a] +safeInit xs = case si xs of + (False, _) -> Nothing + (_, ys) -> Just ys + +si :: [a] -> (Bool, [a]) +si xs0 = foldr go stop xs0 Nothing + where + stop Nothing = (False, []) + stop _ = (True, []) + go x r Nothing = (True, snd (r (Just x))) + go x r (Just p) = (True, p : snd (r (Just x))) + diff --git a/testsuite/tests/cpranal/should_compile/T18401.stderr b/testsuite/tests/cpranal/should_compile/T18401.stderr new file mode 100644 index 0000000000..e299ba4dc7 --- /dev/null +++ b/testsuite/tests/cpranal/should_compile/T18401.stderr @@ -0,0 +1,35 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core = {terms: 54, types: 101, coercions: 0, joins: 0/0} + +Rec { +-- RHS size: {terms: 20, types: 31, coercions: 0, joins: 0/0} +T18401.safeInit_$spoly_$wgo1 :: forall {a}. a -> [a] -> (# Bool, [a] #) +T18401.safeInit_$spoly_$wgo1 + = \ (@a_aO1) (sc_s17W :: a_aO1) (sc1_s17V :: [a_aO1]) -> + case sc1_s17V of { + [] -> (# GHC.Types.True, GHC.Types.[] @a_aO1 #); + : y_a158 ys_a159 -> (# GHC.Types.True, GHC.Types.: @a_aO1 sc_s17W (case T18401.safeInit_$spoly_$wgo1 @a_aO1 y_a158 ys_a159 of { (# ww_s17y, ww1_s17z #) -> ww1_s17z }) #) + } +end Rec } + +-- RHS size: {terms: 17, types: 25, coercions: 0, joins: 0/0} +si :: forall a. [a] -> (Bool, [a]) +si + = \ (@a_s17i) (w_s17j :: [a_s17i]) -> + case w_s17j of { + [] -> (GHC.Types.False, GHC.Types.[] @a_s17i); + : y_a158 ys_a159 -> (GHC.Types.True, case T18401.safeInit_$spoly_$wgo1 @a_s17i y_a158 ys_a159 of { (# ww_X3, ww1_X4 #) -> ww1_X4 }) + } + +-- RHS size: {terms: 14, types: 22, coercions: 0, joins: 0/0} +safeInit :: forall a. [a] -> Maybe [a] +safeInit + = \ (@a_aO1) (xs_aus :: [a_aO1]) -> + case xs_aus of { + [] -> GHC.Maybe.Nothing @[a_aO1]; + : y_a158 ys_a159 -> GHC.Maybe.Just @[a_aO1] (case T18401.safeInit_$spoly_$wgo1 @a_aO1 y_a158 ys_a159 of { (# ww_X3, ww1_X4 #) -> ww1_X4 }) + } + + + diff --git a/testsuite/tests/cpranal/should_compile/all.T b/testsuite/tests/cpranal/should_compile/all.T index 5a37f42376..d70d978be6 100644 --- a/testsuite/tests/cpranal/should_compile/all.T +++ b/testsuite/tests/cpranal/should_compile/all.T @@ -5,3 +5,9 @@ def f( name, opts ): setTestOpts(f) test('Cpr001', [], multimod_compile, ['Cpr001', '-v0']) +# The following tests grep for type signatures of worker functions. +test('T18109', [ grep_errmsg(r'^T18109\.\$w\S+ ::') ], compile, ['-ddump-simpl -dsuppress-idinfo -dppr-cols=9999']) +# T18401 probably needs -flate-dmd-anal so that it runs after SpecConstr. +# It is currently broken, but not marked expect_broken. We can't know the exact +# name of the function before it is fixed, so expect_broken doesn't make sense. +test('T18401', [ grep_errmsg(r'^T18401\.\S+ ::') ], compile, ['-ddump-simpl -dsuppress-idinfo -dppr-cols=9999 -flate-dmd-anal']) diff --git a/testsuite/tests/driver/dynamicToo/ARecomp.hs b/testsuite/tests/driver/dynamicToo/ARecomp.hs new file mode 100644 index 0000000000..c760d18753 --- /dev/null +++ b/testsuite/tests/driver/dynamicToo/ARecomp.hs @@ -0,0 +1,3 @@ +module ARecomp where + +main = print () diff --git a/testsuite/tests/driver/dynamicToo/Makefile b/testsuite/tests/driver/dynamicToo/Makefile index b1eab7ef30..33b6a5a9cb 100644 --- a/testsuite/tests/driver/dynamicToo/Makefile +++ b/testsuite/tests/driver/dynamicToo/Makefile @@ -3,6 +3,7 @@ include $(TOP)/mk/boilerplate.mk include $(TOP)/mk/test.mk checkExists = [ -f $1 ] || echo $1 missing +checkMissing = [ ! -f $1 ] || echo $1 exists .PHONY: dynamicToo003 # Check that "-c -dynamic-too" works @@ -13,3 +14,32 @@ dynamicToo003: $(call checkExists,A003.dyn_o) $(call checkExists,A003.dyn_hi) +.PHONY: dynamicTooRecomp +# Check that recompilation with "-c -dynamic-too" works +dynamicTooRecomp: + "$(TEST_HC)" $(TEST_HC_OPTS) -dynamic-too -v0 -c ARecomp.hs + # Remove just dynamic objects + $(RM) ARecomp.dyn* + # Recompile + "$(TEST_HC)" $(TEST_HC_OPTS) -dynamic-too -v0 -c ARecomp.hs + # Check everything is there + $(call checkExists,ARecomp.o) + $(call checkExists,ARecomp.hi) + $(call checkExists,ARecomp.dyn_o) + $(call checkExists,ARecomp.dyn_hi) + +.PHONY: dynamicTooOnlyInterface +# Check that a missing .dyn_o does not cause recompilation when `-fno-code` `-fwrite-interface` +# is combined +dynamicTooOnlyInterface: + "$(TEST_HC)" $(TEST_HC_OPTS) -dynamic-too -v0 -c ARecomp.hs + # Remove just dynamic objects + $(RM) ARecomp.dyn* + # Recompile, using -fno-code -fwrite-interface + "$(TEST_HC)" $(TEST_HC_OPTS) -fno-code -fwrite-interface -v0 -c ARecomp.hs + # Check the right things are there + $(call checkExists,ARecomp.o) + $(call checkExists,ARecomp.hi) + $(call checkMissing,ARecomp.dyn_o) + $(call checkMissing,ARecomp.dyn_hi) + diff --git a/testsuite/tests/driver/dynamicToo/all.T b/testsuite/tests/driver/dynamicToo/all.T index 0c890efd70..28fedc7863 100644 --- a/testsuite/tests/driver/dynamicToo/all.T +++ b/testsuite/tests/driver/dynamicToo/all.T @@ -3,3 +3,13 @@ test('dynamicToo003', [extra_files(['A003.hs']), unless(have_vanilla(), skip), unless(have_dynamic(), skip)], makefile_test, []) + +test('dynamicTooRecomp', + [extra_files(['ARecomp.hs']), + unless(have_vanilla(), skip), unless(have_dynamic(), skip)], + makefile_test, []) + +test('dynamicTooOnlyInterface', + [extra_files(['ARecomp.hs']), + unless(have_vanilla(), skip), unless(have_dynamic(), skip)], + makefile_test, []) diff --git a/testsuite/tests/ghci/linking/Makefile b/testsuite/tests/ghci/linking/Makefile index 085e81765b..2c71e96cc6 100644 --- a/testsuite/tests/ghci/linking/Makefile +++ b/testsuite/tests/ghci/linking/Makefile @@ -24,6 +24,12 @@ else DLL = lib$1.so endif +ifeq "$(FREEBSD)" "YES" +LIBCXX=c++ +else +LIBCXX=stdc++ +endif + .PHONY: ghcilink002 ghcilink002 : $(RM) -rf dir002 @@ -38,7 +44,7 @@ ghcilink002 : .PHONY: ghcilink003 ghcilink003 : - echo ":q" | "$(TEST_HC)" $(TEST_HC_OPTS_INTERACTIVE) -lstdc++ + echo ":q" | "$(TEST_HC)" $(TEST_HC_OPTS_INTERACTIVE) -l$(LIBCXX) # Test 4: # package P @@ -115,7 +121,7 @@ ghcilink006 : ifeq "$(WINDOWS)" "YES" echo "extra-libraries: stdc++-6" >>$(PKG006) else - echo "extra-libraries: stdc++" >>$(PKG006) + echo "extra-libraries: $(LIBCXX)" >>$(PKG006) endif '$(GHC_PKG)' init $(LOCAL_PKGCONF006) '$(GHC_PKG)' --no-user-package-db -f $(LOCAL_PKGCONF006) register $(PKG006) -v0 diff --git a/testsuite/tests/ghci/linking/all.T b/testsuite/tests/ghci/linking/all.T index 79ec5e5f98..743067518f 100644 --- a/testsuite/tests/ghci/linking/all.T +++ b/testsuite/tests/ghci/linking/all.T @@ -12,8 +12,8 @@ test('ghcilink002', [extra_files(['TestLink.hs', 'f.c']), test('ghcilink003', [unless(doing_ghci, skip), - # libstdc++ is named differently on FreeBSD - when(opsys('freebsd'), expect_broken(17739))], + # libstdc++ is GCC-specific on FreeBSD + when(opsys('freebsd'), fragile(17739))], makefile_test, ['ghcilink003']) @@ -32,8 +32,8 @@ test('ghcilink005', test('ghcilink006', [unless(doing_ghci, skip), - # libstdc++ is named differently on FreeBSD - when(opsys('freebsd'), expect_broken(17739))], + # libstdc++ is GCC-specific on FreeBSD + when(opsys('freebsd'), fragile(17739))], makefile_test, ['ghcilink006']) diff --git a/testsuite/tests/ghci/scripts/Makefile b/testsuite/tests/ghci/scripts/Makefile index 40ba561f69..a76b8c090c 100644 --- a/testsuite/tests/ghci/scripts/Makefile +++ b/testsuite/tests/ghci/scripts/Makefile @@ -66,3 +66,7 @@ T11389: T12023: -'$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) \ -ghci-script T12023.script < /dev/null | grep -c -E '(~#|~R#|~P#)' + +.PHONY: T19650_setup +T19650_setup: + '$(GHC_PKG)' latest base > my_package_env diff --git a/testsuite/tests/ghci/scripts/T19650.script b/testsuite/tests/ghci/scripts/T19650.script new file mode 100644 index 0000000000..1426870840 --- /dev/null +++ b/testsuite/tests/ghci/scripts/T19650.script @@ -0,0 +1 @@ +:set -DMAGIC diff --git a/testsuite/tests/ghci/scripts/T19650.stdout b/testsuite/tests/ghci/scripts/T19650.stdout new file mode 100644 index 0000000000..4bca5be26b --- /dev/null +++ b/testsuite/tests/ghci/scripts/T19650.stdout @@ -0,0 +1 @@ +Loaded package environment from my_package_env diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T index ff6d357c7b..46b6f41c2a 100755 --- a/testsuite/tests/ghci/scripts/all.T +++ b/testsuite/tests/ghci/scripts/all.T @@ -330,3 +330,11 @@ test('T19279', normal, ghci_script, ['T19279.script']) test('T19310', normal, ghci_script, ['T19310.script']) test('T19667Ghci', extra_files(['T19667Ghci.hs']), ghci_script, ['T19667Ghci.script']) test('T19688', normal, ghci_script, ['T19688.script']) +test('T19650', + [ pre_cmd('$MAKE -s --no-print-directory T19650_setup'), + extra_hc_opts('-package-env my_package_env -v1'), + # Should only appear once + filter_stdout_lines(r'Loaded package env.*') + ], + ghci_script, + ['T19650.script']) diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr index 7e34424807..db88734005 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr @@ -9,8 +9,8 @@ { T17544.hs:1:1 } (UnchangedAnchor)) (AnnsModule - [(AddEpAnn AnnModule (AR { T17544.hs:3:1-6 })) - ,(AddEpAnn AnnWhere (AR { T17544.hs:3:15-19 }))] + [(AddEpAnn AnnModule (EpaSpan { T17544.hs:3:1-6 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:3:15-19 }))] (AnnList (Nothing) (Nothing) @@ -51,8 +51,8 @@ (Anchor { T17544.hs:(5,1)-(6,16) } (UnchangedAnchor)) - [(AddEpAnn AnnClass (AR { T17544.hs:5:1-5 })) - ,(AddEpAnn AnnWhere (AR { T17544.hs:5:12-16 }))] + [(AddEpAnn AnnClass (EpaSpan { T17544.hs:5:1-5 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:5:12-16 }))] (EpaComments [])) (NoAnnSortKey) @@ -90,7 +90,7 @@ { T17544.hs:6:3-4 } (UnchangedAnchor)) (AnnSig - (AddEpAnn AnnDcolon (AR { T17544.hs:6:6-7 })) + (AddEpAnn AnnDcolon (EpaSpan { T17544.hs:6:6-7 })) []) (EpaComments [])) @@ -113,7 +113,7 @@ { T17544.hs:6:9 } (UnchangedAnchor)) (AddRarrowAnn - (AR { T17544.hs:6:11-12 })) + (EpaSpan { T17544.hs:6:11-12 })) (EpaComments [])) (HsUnrestrictedArrow @@ -178,8 +178,8 @@ (Anchor { T17544.hs:(9,1)-(10,16) } (UnchangedAnchor)) - [(AddEpAnn AnnClass (AR { T17544.hs:9:1-5 })) - ,(AddEpAnn AnnWhere (AR { T17544.hs:9:12-16 }))] + [(AddEpAnn AnnClass (EpaSpan { T17544.hs:9:1-5 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:9:12-16 }))] (EpaComments [])) (NoAnnSortKey) @@ -217,7 +217,7 @@ { T17544.hs:10:3-4 } (UnchangedAnchor)) (AnnSig - (AddEpAnn AnnDcolon (AR { T17544.hs:10:6-7 })) + (AddEpAnn AnnDcolon (EpaSpan { T17544.hs:10:6-7 })) []) (EpaComments [])) @@ -240,7 +240,7 @@ { T17544.hs:10:9 } (UnchangedAnchor)) (AddRarrowAnn - (AR { T17544.hs:10:11-12 })) + (EpaSpan { T17544.hs:10:11-12 })) (EpaComments [])) (HsUnrestrictedArrow @@ -301,8 +301,8 @@ (Anchor { T17544.hs:(13,1)-(14,16) } (UnchangedAnchor)) - [(AddEpAnn AnnClass (AR { T17544.hs:13:1-5 })) - ,(AddEpAnn AnnWhere (AR { T17544.hs:13:12-16 }))] + [(AddEpAnn AnnClass (EpaSpan { T17544.hs:13:1-5 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:13:12-16 }))] (EpaComments [])) (NoAnnSortKey) @@ -340,7 +340,7 @@ { T17544.hs:14:3-4 } (UnchangedAnchor)) (AnnSig - (AddEpAnn AnnDcolon (AR { T17544.hs:14:6-7 })) + (AddEpAnn AnnDcolon (EpaSpan { T17544.hs:14:6-7 })) []) (EpaComments [])) @@ -363,7 +363,7 @@ { T17544.hs:14:9 } (UnchangedAnchor)) (AddRarrowAnn - (AR { T17544.hs:14:11-12 })) + (EpaSpan { T17544.hs:14:11-12 })) (EpaComments [])) (HsUnrestrictedArrow @@ -427,8 +427,8 @@ (Anchor { T17544.hs:(17,1)-(20,16) } (UnchangedAnchor)) - [(AddEpAnn AnnClass (AR { T17544.hs:17:1-5 })) - ,(AddEpAnn AnnWhere (AR { T17544.hs:17:12-16 }))] + [(AddEpAnn AnnClass (EpaSpan { T17544.hs:17:1-5 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:17:12-16 }))] (EpaComments [])) (NoAnnSortKey) @@ -466,7 +466,7 @@ { T17544.hs:18:3-4 } (UnchangedAnchor)) (AnnSig - (AddEpAnn AnnDcolon (AR { T17544.hs:18:6-7 })) + (AddEpAnn AnnDcolon (EpaSpan { T17544.hs:18:6-7 })) []) (EpaComments [])) @@ -489,7 +489,7 @@ { T17544.hs:18:9 } (UnchangedAnchor)) (AddRarrowAnn - (AR { T17544.hs:18:11-12 })) + (EpaSpan { T17544.hs:18:11-12 })) (EpaComments [])) (HsUnrestrictedArrow @@ -532,7 +532,7 @@ { T17544.hs:20:3-4 } (UnchangedAnchor)) (AnnSig - (AddEpAnn AnnDcolon (AR { T17544.hs:20:6-7 })) + (AddEpAnn AnnDcolon (EpaSpan { T17544.hs:20:6-7 })) []) (EpaComments [])) @@ -555,7 +555,7 @@ { T17544.hs:20:9 } (UnchangedAnchor)) (AddRarrowAnn - (AR { T17544.hs:20:11-12 })) + (EpaSpan { T17544.hs:20:11-12 })) (EpaComments [])) (HsUnrestrictedArrow @@ -612,10 +612,10 @@ (Anchor { T17544.hs:22:1-30 } (UnchangedAnchor)) - [(AddEpAnn AnnClass (AR { T17544.hs:22:1-5 })) - ,(AddEpAnn AnnWhere (AR { T17544.hs:22:12-16 })) - ,(AddEpAnn AnnOpenC (AR { T17544.hs:22:18 })) - ,(AddEpAnn AnnCloseC (AR { T17544.hs:22:30 }))] + [(AddEpAnn AnnClass (EpaSpan { T17544.hs:22:1-5 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:22:12-16 })) + ,(AddEpAnn AnnOpenC (EpaSpan { T17544.hs:22:18 })) + ,(AddEpAnn AnnCloseC (EpaSpan { T17544.hs:22:30 }))] (EpaComments [])) (NoAnnSortKey) @@ -654,7 +654,7 @@ (Anchor { T17544.hs:22:20-28 } (UnchangedAnchor)) - [(AddEpAnn AnnData (AR { T17544.hs:22:20-23 }))] + [(AddEpAnn AnnData (EpaSpan { T17544.hs:22:20-23 }))] (EpaComments [])) (DataFamily) @@ -707,8 +707,8 @@ (Anchor { T17544.hs:23:1-8 } (UnchangedAnchor)) - [(AddEpAnn AnnInstance (AR { T17544.hs:23:1-8 })) - ,(AddEpAnn AnnWhere (AR { T17544.hs:23:17-21 }))] + [(AddEpAnn AnnInstance (EpaSpan { T17544.hs:23:1-8 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:23:17-21 }))] (EpaComments [])) (NoAnnSortKey)) @@ -789,8 +789,8 @@ (Anchor { T17544.hs:(24,3)-(25,18) } (UnchangedAnchor)) - [(AddEpAnn AnnData (AR { T17544.hs:24:3-6 })) - ,(AddEpAnn AnnWhere (AR { T17544.hs:24:15-19 }))] + [(AddEpAnn AnnData (EpaSpan { T17544.hs:24:3-6 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:24:15-19 }))] (EpaComments [])) (DataType) @@ -804,7 +804,7 @@ (Anchor { T17544.hs:25:5-18 } (UnchangedAnchor)) - [(AddEpAnn AnnDcolon (AR { T17544.hs:25:10-11 }))] + [(AddEpAnn AnnDcolon (EpaSpan { T17544.hs:25:10-11 }))] (EpaComments [])) [(L @@ -872,10 +872,10 @@ (Anchor { T17544.hs:28:1-30 } (UnchangedAnchor)) - [(AddEpAnn AnnClass (AR { T17544.hs:28:1-5 })) - ,(AddEpAnn AnnWhere (AR { T17544.hs:28:12-16 })) - ,(AddEpAnn AnnOpenC (AR { T17544.hs:28:18 })) - ,(AddEpAnn AnnCloseC (AR { T17544.hs:28:30 }))] + [(AddEpAnn AnnClass (EpaSpan { T17544.hs:28:1-5 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:28:12-16 })) + ,(AddEpAnn AnnOpenC (EpaSpan { T17544.hs:28:18 })) + ,(AddEpAnn AnnCloseC (EpaSpan { T17544.hs:28:30 }))] (EpaComments [])) (NoAnnSortKey) @@ -914,7 +914,7 @@ (Anchor { T17544.hs:28:20-28 } (UnchangedAnchor)) - [(AddEpAnn AnnData (AR { T17544.hs:28:20-23 }))] + [(AddEpAnn AnnData (EpaSpan { T17544.hs:28:20-23 }))] (EpaComments [])) (DataFamily) @@ -967,8 +967,8 @@ (Anchor { T17544.hs:29:1-8 } (UnchangedAnchor)) - [(AddEpAnn AnnInstance (AR { T17544.hs:29:1-8 })) - ,(AddEpAnn AnnWhere (AR { T17544.hs:29:17-21 }))] + [(AddEpAnn AnnInstance (EpaSpan { T17544.hs:29:1-8 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:29:17-21 }))] (EpaComments [])) (NoAnnSortKey)) @@ -1049,8 +1049,8 @@ (Anchor { T17544.hs:(30,3)-(31,18) } (UnchangedAnchor)) - [(AddEpAnn AnnData (AR { T17544.hs:30:3-6 })) - ,(AddEpAnn AnnWhere (AR { T17544.hs:30:15-19 }))] + [(AddEpAnn AnnData (EpaSpan { T17544.hs:30:3-6 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:30:15-19 }))] (EpaComments [])) (DataType) @@ -1064,7 +1064,7 @@ (Anchor { T17544.hs:31:5-18 } (UnchangedAnchor)) - [(AddEpAnn AnnDcolon (AR { T17544.hs:31:10-11 }))] + [(AddEpAnn AnnDcolon (EpaSpan { T17544.hs:31:10-11 }))] (EpaComments [])) [(L @@ -1132,10 +1132,10 @@ (Anchor { T17544.hs:34:1-30 } (UnchangedAnchor)) - [(AddEpAnn AnnClass (AR { T17544.hs:34:1-5 })) - ,(AddEpAnn AnnWhere (AR { T17544.hs:34:12-16 })) - ,(AddEpAnn AnnOpenC (AR { T17544.hs:34:18 })) - ,(AddEpAnn AnnCloseC (AR { T17544.hs:34:30 }))] + [(AddEpAnn AnnClass (EpaSpan { T17544.hs:34:1-5 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:34:12-16 })) + ,(AddEpAnn AnnOpenC (EpaSpan { T17544.hs:34:18 })) + ,(AddEpAnn AnnCloseC (EpaSpan { T17544.hs:34:30 }))] (EpaComments [])) (NoAnnSortKey) @@ -1174,7 +1174,7 @@ (Anchor { T17544.hs:34:20-28 } (UnchangedAnchor)) - [(AddEpAnn AnnData (AR { T17544.hs:34:20-23 }))] + [(AddEpAnn AnnData (EpaSpan { T17544.hs:34:20-23 }))] (EpaComments [])) (DataFamily) @@ -1227,8 +1227,8 @@ (Anchor { T17544.hs:35:1-8 } (UnchangedAnchor)) - [(AddEpAnn AnnInstance (AR { T17544.hs:35:1-8 })) - ,(AddEpAnn AnnWhere (AR { T17544.hs:35:17-21 }))] + [(AddEpAnn AnnInstance (EpaSpan { T17544.hs:35:1-8 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:35:17-21 }))] (EpaComments [])) (NoAnnSortKey)) @@ -1309,8 +1309,8 @@ (Anchor { T17544.hs:(36,3)-(37,18) } (UnchangedAnchor)) - [(AddEpAnn AnnData (AR { T17544.hs:36:3-6 })) - ,(AddEpAnn AnnWhere (AR { T17544.hs:36:15-19 }))] + [(AddEpAnn AnnData (EpaSpan { T17544.hs:36:3-6 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:36:15-19 }))] (EpaComments [])) (DataType) @@ -1324,7 +1324,7 @@ (Anchor { T17544.hs:37:5-18 } (UnchangedAnchor)) - [(AddEpAnn AnnDcolon (AR { T17544.hs:37:10-11 }))] + [(AddEpAnn AnnDcolon (EpaSpan { T17544.hs:37:10-11 }))] (EpaComments [])) [(L @@ -1392,10 +1392,10 @@ (Anchor { T17544.hs:40:1-30 } (UnchangedAnchor)) - [(AddEpAnn AnnClass (AR { T17544.hs:40:1-5 })) - ,(AddEpAnn AnnWhere (AR { T17544.hs:40:12-16 })) - ,(AddEpAnn AnnOpenC (AR { T17544.hs:40:18 })) - ,(AddEpAnn AnnCloseC (AR { T17544.hs:40:30 }))] + [(AddEpAnn AnnClass (EpaSpan { T17544.hs:40:1-5 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:40:12-16 })) + ,(AddEpAnn AnnOpenC (EpaSpan { T17544.hs:40:18 })) + ,(AddEpAnn AnnCloseC (EpaSpan { T17544.hs:40:30 }))] (EpaComments [])) (NoAnnSortKey) @@ -1434,7 +1434,7 @@ (Anchor { T17544.hs:40:20-28 } (UnchangedAnchor)) - [(AddEpAnn AnnData (AR { T17544.hs:40:20-23 }))] + [(AddEpAnn AnnData (EpaSpan { T17544.hs:40:20-23 }))] (EpaComments [])) (DataFamily) @@ -1487,8 +1487,8 @@ (Anchor { T17544.hs:41:1-8 } (UnchangedAnchor)) - [(AddEpAnn AnnInstance (AR { T17544.hs:41:1-8 })) - ,(AddEpAnn AnnWhere (AR { T17544.hs:41:17-21 }))] + [(AddEpAnn AnnInstance (EpaSpan { T17544.hs:41:1-8 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:41:17-21 }))] (EpaComments [])) (NoAnnSortKey)) @@ -1569,8 +1569,8 @@ (Anchor { T17544.hs:(42,3)-(43,18) } (UnchangedAnchor)) - [(AddEpAnn AnnData (AR { T17544.hs:42:3-6 })) - ,(AddEpAnn AnnWhere (AR { T17544.hs:42:15-19 }))] + [(AddEpAnn AnnData (EpaSpan { T17544.hs:42:3-6 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:42:15-19 }))] (EpaComments [])) (DataType) @@ -1584,7 +1584,7 @@ (Anchor { T17544.hs:43:5-18 } (UnchangedAnchor)) - [(AddEpAnn AnnDcolon (AR { T17544.hs:43:10-11 }))] + [(AddEpAnn AnnDcolon (EpaSpan { T17544.hs:43:10-11 }))] (EpaComments [])) [(L @@ -1652,10 +1652,10 @@ (Anchor { T17544.hs:46:1-30 } (UnchangedAnchor)) - [(AddEpAnn AnnClass (AR { T17544.hs:46:1-5 })) - ,(AddEpAnn AnnWhere (AR { T17544.hs:46:12-16 })) - ,(AddEpAnn AnnOpenC (AR { T17544.hs:46:18 })) - ,(AddEpAnn AnnCloseC (AR { T17544.hs:46:30 }))] + [(AddEpAnn AnnClass (EpaSpan { T17544.hs:46:1-5 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:46:12-16 })) + ,(AddEpAnn AnnOpenC (EpaSpan { T17544.hs:46:18 })) + ,(AddEpAnn AnnCloseC (EpaSpan { T17544.hs:46:30 }))] (EpaComments [])) (NoAnnSortKey) @@ -1694,7 +1694,7 @@ (Anchor { T17544.hs:46:20-28 } (UnchangedAnchor)) - [(AddEpAnn AnnData (AR { T17544.hs:46:20-23 }))] + [(AddEpAnn AnnData (EpaSpan { T17544.hs:46:20-23 }))] (EpaComments [])) (DataFamily) @@ -1747,8 +1747,8 @@ (Anchor { T17544.hs:47:1-8 } (UnchangedAnchor)) - [(AddEpAnn AnnInstance (AR { T17544.hs:47:1-8 })) - ,(AddEpAnn AnnWhere (AR { T17544.hs:47:17-21 }))] + [(AddEpAnn AnnInstance (EpaSpan { T17544.hs:47:1-8 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:47:17-21 }))] (EpaComments [])) (NoAnnSortKey)) @@ -1829,8 +1829,8 @@ (Anchor { T17544.hs:(48,3)-(49,18) } (UnchangedAnchor)) - [(AddEpAnn AnnData (AR { T17544.hs:48:3-6 })) - ,(AddEpAnn AnnWhere (AR { T17544.hs:48:15-19 }))] + [(AddEpAnn AnnData (EpaSpan { T17544.hs:48:3-6 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:48:15-19 }))] (EpaComments [])) (DataType) @@ -1844,7 +1844,7 @@ (Anchor { T17544.hs:49:5-18 } (UnchangedAnchor)) - [(AddEpAnn AnnDcolon (AR { T17544.hs:49:10-11 }))] + [(AddEpAnn AnnDcolon (EpaSpan { T17544.hs:49:10-11 }))] (EpaComments [])) [(L @@ -1912,10 +1912,10 @@ (Anchor { T17544.hs:52:1-32 } (UnchangedAnchor)) - [(AddEpAnn AnnClass (AR { T17544.hs:52:1-5 })) - ,(AddEpAnn AnnWhere (AR { T17544.hs:52:13-17 })) - ,(AddEpAnn AnnOpenC (AR { T17544.hs:52:19 })) - ,(AddEpAnn AnnCloseC (AR { T17544.hs:52:32 }))] + [(AddEpAnn AnnClass (EpaSpan { T17544.hs:52:1-5 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:52:13-17 })) + ,(AddEpAnn AnnOpenC (EpaSpan { T17544.hs:52:19 })) + ,(AddEpAnn AnnCloseC (EpaSpan { T17544.hs:52:32 }))] (EpaComments [])) (NoAnnSortKey) @@ -1954,7 +1954,7 @@ (Anchor { T17544.hs:52:21-30 } (UnchangedAnchor)) - [(AddEpAnn AnnData (AR { T17544.hs:52:21-24 }))] + [(AddEpAnn AnnData (EpaSpan { T17544.hs:52:21-24 }))] (EpaComments [])) (DataFamily) @@ -2007,8 +2007,8 @@ (Anchor { T17544.hs:53:1-8 } (UnchangedAnchor)) - [(AddEpAnn AnnInstance (AR { T17544.hs:53:1-8 })) - ,(AddEpAnn AnnWhere (AR { T17544.hs:53:18-22 }))] + [(AddEpAnn AnnInstance (EpaSpan { T17544.hs:53:1-8 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:53:18-22 }))] (EpaComments [])) (NoAnnSortKey)) @@ -2089,8 +2089,8 @@ (Anchor { T17544.hs:(54,3)-(55,20) } (UnchangedAnchor)) - [(AddEpAnn AnnData (AR { T17544.hs:54:3-6 })) - ,(AddEpAnn AnnWhere (AR { T17544.hs:54:16-20 }))] + [(AddEpAnn AnnData (EpaSpan { T17544.hs:54:3-6 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:54:16-20 }))] (EpaComments [])) (DataType) @@ -2104,7 +2104,7 @@ (Anchor { T17544.hs:55:5-20 } (UnchangedAnchor)) - [(AddEpAnn AnnDcolon (AR { T17544.hs:55:11-12 }))] + [(AddEpAnn AnnDcolon (EpaSpan { T17544.hs:55:11-12 }))] (EpaComments [])) [(L diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr index b00f2efdeb..6d58a727af 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr @@ -9,8 +9,8 @@ { T17544_kw.hs:1:1 } (UnchangedAnchor)) (AnnsModule - [(AddEpAnn AnnModule (AR { T17544_kw.hs:11:1-6 })) - ,(AddEpAnn AnnWhere (AR { T17544_kw.hs:13:13-17 }))] + [(AddEpAnn AnnModule (EpaSpan { T17544_kw.hs:11:1-6 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544_kw.hs:13:13-17 }))] (AnnList (Nothing) (Nothing) @@ -50,8 +50,8 @@ (Anchor { T17544_kw.hs:(15,1)-(16,20) } (UnchangedAnchor)) - [(AddEpAnn AnnData (AR { T17544_kw.hs:15:1-4 })) - ,(AddEpAnn AnnWhere (AR { T17544_kw.hs:16:3-7 }))] + [(AddEpAnn AnnData (EpaSpan { T17544_kw.hs:15:1-4 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544_kw.hs:16:3-7 }))] (EpaComments [])) (L @@ -67,8 +67,8 @@ (Anchor { T17544_kw.hs:(15,1)-(16,20) } (UnchangedAnchor)) - [(AddEpAnn AnnData (AR { T17544_kw.hs:15:1-4 })) - ,(AddEpAnn AnnWhere (AR { T17544_kw.hs:16:3-7 }))] + [(AddEpAnn AnnData (EpaSpan { T17544_kw.hs:15:1-4 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544_kw.hs:16:3-7 }))] (EpaComments [])) (DataType) @@ -82,7 +82,7 @@ (Anchor { T17544_kw.hs:16:9-20 } (UnchangedAnchor)) - [(AddEpAnn AnnDcolon (AR { T17544_kw.hs:16:15-16 }))] + [(AddEpAnn AnnDcolon (EpaSpan { T17544_kw.hs:16:15-16 }))] (EpaComments [])) [(L @@ -133,8 +133,8 @@ (Anchor { T17544_kw.hs:(18,1)-(19,26) } (UnchangedAnchor)) - [(AddEpAnn AnnNewtype (AR { T17544_kw.hs:18:1-7 })) - ,(AddEpAnn AnnWhere (AR { T17544_kw.hs:19:3-7 }))] + [(AddEpAnn AnnNewtype (EpaSpan { T17544_kw.hs:18:1-7 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544_kw.hs:19:3-7 }))] (EpaComments [])) (L @@ -150,8 +150,8 @@ (Anchor { T17544_kw.hs:(18,1)-(19,26) } (UnchangedAnchor)) - [(AddEpAnn AnnNewtype (AR { T17544_kw.hs:18:1-7 })) - ,(AddEpAnn AnnWhere (AR { T17544_kw.hs:19:3-7 }))] + [(AddEpAnn AnnNewtype (EpaSpan { T17544_kw.hs:18:1-7 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544_kw.hs:19:3-7 }))] (EpaComments [])) (NewType) @@ -165,7 +165,7 @@ (Anchor { T17544_kw.hs:19:9-26 } (UnchangedAnchor)) - [(AddEpAnn AnnDcolon (AR { T17544_kw.hs:19:15-16 }))] + [(AddEpAnn AnnDcolon (EpaSpan { T17544_kw.hs:19:15-16 }))] (EpaComments [])) [(L @@ -188,7 +188,7 @@ (UnchangedAnchor)) (AnnListItem [(AddRarrowAnn - (AR { T17544_kw.hs:19:21-22 }))]) + (EpaSpan { T17544_kw.hs:19:21-22 }))]) (EpaComments [])) { T17544_kw.hs:19:18-19 }) (HsTupleTy @@ -198,8 +198,8 @@ (UnchangedAnchor)) (AnnParen (AnnParens) - (AR { T17544_kw.hs:19:18 }) - (AR { T17544_kw.hs:19:19 })) + (EpaSpan { T17544_kw.hs:19:18 }) + (EpaSpan { T17544_kw.hs:19:19 })) (EpaComments [])) (HsBoxedOrConstraintTuple) @@ -242,8 +242,8 @@ (Anchor { T17544_kw.hs:(21,1)-(24,18) } (UnchangedAnchor)) - [(AddEpAnn AnnClass (AR { T17544_kw.hs:21:1-5 })) - ,(AddEpAnn AnnWhere (AR { T17544_kw.hs:23:3-7 }))] + [(AddEpAnn AnnClass (EpaSpan { T17544_kw.hs:21:1-5 })) + ,(AddEpAnn AnnWhere (EpaSpan { T17544_kw.hs:23:3-7 }))] (EpaComments [])) (NoAnnSortKey) @@ -281,7 +281,7 @@ { T17544_kw.hs:24:5-13 } (UnchangedAnchor)) (AnnSig - (AddEpAnn AnnDcolon (AR { T17544_kw.hs:24:15-16 })) + (AddEpAnn AnnDcolon (EpaSpan { T17544_kw.hs:24:15-16 })) []) (EpaComments [])) diff --git a/testsuite/tests/module/mod185.stderr b/testsuite/tests/module/mod185.stderr index bc428b5d0b..62427a5746 100644 --- a/testsuite/tests/module/mod185.stderr +++ b/testsuite/tests/module/mod185.stderr @@ -37,11 +37,11 @@ { mod185.hs:3:1-6 } (UnchangedAnchor)) (EpAnnImportDecl - (AR { mod185.hs:3:1-6 }) + (EpaSpan { mod185.hs:3:1-6 }) (Nothing) (Nothing) (Just - (AR { mod185.hs:3:16-24 })) + (EpaSpan { mod185.hs:3:16-24 })) (Nothing) (Nothing)) (EpaComments @@ -107,7 +107,7 @@ (UnchangedAnchor)) (GrhsAnn (Nothing) - (AddEpAnn AnnEqual (AR { mod185.hs:5:6 }))) + (AddEpAnn AnnEqual (EpaSpan { mod185.hs:5:6 }))) (EpaComments [])) [] diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr index 332e6e4822..d4956a81e4 100644 --- a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr @@ -9,8 +9,8 @@ { DumpParsedAst.hs:1:1 } (UnchangedAnchor)) (AnnsModule - [(AddEpAnn AnnModule (AR { DumpParsedAst.hs:5:1-6 })) - ,(AddEpAnn AnnWhere (AR { DumpParsedAst.hs:5:22-26 }))] + [(AddEpAnn AnnModule (EpaSpan { DumpParsedAst.hs:5:1-6 })) + ,(AddEpAnn AnnWhere (EpaSpan { DumpParsedAst.hs:5:22-26 }))] (AnnList (Nothing) (Nothing) @@ -41,7 +41,7 @@ { DumpParsedAst.hs:6:1-6 } (UnchangedAnchor)) (EpAnnImportDecl - (AR { DumpParsedAst.hs:6:1-6 }) + (EpaSpan { DumpParsedAst.hs:6:1-6 }) (Nothing) (Nothing) (Nothing) @@ -76,8 +76,8 @@ (Anchor { DumpParsedAst.hs:8:1-30 } (UnchangedAnchor)) - [(AddEpAnn AnnData (AR { DumpParsedAst.hs:8:1-4 })) - ,(AddEpAnn AnnEqual (AR { DumpParsedAst.hs:8:12 }))] + [(AddEpAnn AnnData (EpaSpan { DumpParsedAst.hs:8:1-4 })) + ,(AddEpAnn AnnEqual (EpaSpan { DumpParsedAst.hs:8:12 }))] (EpaComments [])) (L @@ -93,8 +93,8 @@ (Anchor { DumpParsedAst.hs:8:1-30 } (UnchangedAnchor)) - [(AddEpAnn AnnData (AR { DumpParsedAst.hs:8:1-4 })) - ,(AddEpAnn AnnEqual (AR { DumpParsedAst.hs:8:12 }))] + [(AddEpAnn AnnData (EpaSpan { DumpParsedAst.hs:8:1-4 })) + ,(AddEpAnn AnnEqual (EpaSpan { DumpParsedAst.hs:8:12 }))] (EpaComments [])) (DataType) @@ -108,7 +108,7 @@ (UnchangedAnchor)) (AnnListItem [(AddVbarAnn - (AR { DumpParsedAst.hs:8:19 }))]) + (EpaSpan { DumpParsedAst.hs:8:19 }))]) (EpaComments [])) { DumpParsedAst.hs:8:14-17 }) (ConDeclH98 @@ -188,12 +188,12 @@ (Anchor { DumpParsedAst.hs:10:1-45 } (UnchangedAnchor)) - [(AddEpAnn AnnType (AR { DumpParsedAst.hs:10:1-4 })) - ,(AddEpAnn AnnFamily (AR { DumpParsedAst.hs:10:6-11 })) - ,(AddEpAnn AnnDcolon (AR { DumpParsedAst.hs:10:32-33 })) - ,(AddEpAnn AnnWhere (AR { DumpParsedAst.hs:10:41-45 })) - ,(AddEpAnn AnnCloseP (AR { DumpParsedAst.hs:10:30 })) - ,(AddEpAnn AnnOpenP (AR { DumpParsedAst.hs:10:20 }))] + [(AddEpAnn AnnType (EpaSpan { DumpParsedAst.hs:10:1-4 })) + ,(AddEpAnn AnnFamily (EpaSpan { DumpParsedAst.hs:10:6-11 })) + ,(AddEpAnn AnnDcolon (EpaSpan { DumpParsedAst.hs:10:32-33 })) + ,(AddEpAnn AnnWhere (EpaSpan { DumpParsedAst.hs:10:41-45 })) + ,(AddEpAnn AnnCloseP (EpaSpan { DumpParsedAst.hs:10:30 })) + ,(AddEpAnn AnnOpenP (EpaSpan { DumpParsedAst.hs:10:20 }))] (EpaComments [])) (ClosedTypeFamily @@ -205,7 +205,7 @@ (Anchor { DumpParsedAst.hs:11:3-36 } (UnchangedAnchor)) - [(AddEpAnn AnnEqual (AR { DumpParsedAst.hs:11:19 }))] + [(AddEpAnn AnnEqual (EpaSpan { DumpParsedAst.hs:11:19 }))] (EpaComments [])) (L @@ -224,8 +224,8 @@ (UnchangedAnchor)) (AnnParen (AnnParens) - (AR { DumpParsedAst.hs:11:10 }) - (AR { DumpParsedAst.hs:11:17 })) + (EpaSpan { DumpParsedAst.hs:11:10 }) + (EpaSpan { DumpParsedAst.hs:11:17 })) (EpaComments [])) (L @@ -295,8 +295,8 @@ (UnchangedAnchor)) (AnnParen (AnnParens) - (AR { DumpParsedAst.hs:11:26 }) - (AR { DumpParsedAst.hs:11:36 })) + (EpaSpan { DumpParsedAst.hs:11:26 }) + (EpaSpan { DumpParsedAst.hs:11:36 })) (EpaComments [])) (L @@ -340,7 +340,7 @@ (Anchor { DumpParsedAst.hs:12:3-24 } (UnchangedAnchor)) - [(AddEpAnn AnnEqual (AR { DumpParsedAst.hs:12:19 }))] + [(AddEpAnn AnnEqual (EpaSpan { DumpParsedAst.hs:12:19 }))] (EpaComments [])) (L @@ -357,9 +357,9 @@ (Anchor { DumpParsedAst.hs:12:10 } (UnchangedAnchor)) - [(AddEpAnn AnnSimpleQuote (AR { DumpParsedAst.hs:12:10 })) - ,(AddEpAnn AnnOpenS (AR { DumpParsedAst.hs:12:11 })) - ,(AddEpAnn AnnCloseS (AR { DumpParsedAst.hs:12:12 }))] + [(AddEpAnn AnnSimpleQuote (EpaSpan { DumpParsedAst.hs:12:10 })) + ,(AddEpAnn AnnOpenS (EpaSpan { DumpParsedAst.hs:12:11 })) + ,(AddEpAnn AnnCloseS (EpaSpan { DumpParsedAst.hs:12:12 }))] (EpaComments [])) (IsPromoted) @@ -394,9 +394,9 @@ (Anchor { DumpParsedAst.hs:10:20-30 } (UnchangedAnchor)) - [(AddEpAnn AnnDcolon (AR { DumpParsedAst.hs:10:24-25 })) - ,(AddEpAnn AnnOpenP (AR { DumpParsedAst.hs:10:20 })) - ,(AddEpAnn AnnCloseP (AR { DumpParsedAst.hs:10:30 }))] + [(AddEpAnn AnnDcolon (EpaSpan { DumpParsedAst.hs:10:24-25 })) + ,(AddEpAnn AnnOpenP (EpaSpan { DumpParsedAst.hs:10:20 })) + ,(AddEpAnn AnnCloseP (EpaSpan { DumpParsedAst.hs:10:30 }))] (EpaComments [])) (()) @@ -413,8 +413,8 @@ (UnchangedAnchor)) (AnnParen (AnnParensSquare) - (AR { DumpParsedAst.hs:10:27 }) - (AR { DumpParsedAst.hs:10:29 })) + (EpaSpan { DumpParsedAst.hs:10:27 }) + (EpaSpan { DumpParsedAst.hs:10:29 })) (EpaComments [])) (L @@ -469,10 +469,10 @@ (Anchor { DumpParsedAst.hs:15:1-29 } (UnchangedAnchor)) - [(AddEpAnn AnnData (AR { DumpParsedAst.hs:15:1-4 })) - ,(AddEpAnn AnnEqual (AR { DumpParsedAst.hs:15:19 })) - ,(AddEpAnn AnnCloseP (AR { DumpParsedAst.hs:15:17 })) - ,(AddEpAnn AnnOpenP (AR { DumpParsedAst.hs:15:10 }))] + [(AddEpAnn AnnData (EpaSpan { DumpParsedAst.hs:15:1-4 })) + ,(AddEpAnn AnnEqual (EpaSpan { DumpParsedAst.hs:15:19 })) + ,(AddEpAnn AnnCloseP (EpaSpan { DumpParsedAst.hs:15:17 })) + ,(AddEpAnn AnnOpenP (EpaSpan { DumpParsedAst.hs:15:10 }))] (EpaComments [])) (L @@ -503,9 +503,9 @@ (Anchor { DumpParsedAst.hs:15:10-17 } (UnchangedAnchor)) - [(AddEpAnn AnnDcolon (AR { DumpParsedAst.hs:15:13-14 })) - ,(AddEpAnn AnnOpenP (AR { DumpParsedAst.hs:15:10 })) - ,(AddEpAnn AnnCloseP (AR { DumpParsedAst.hs:15:17 }))] + [(AddEpAnn AnnDcolon (EpaSpan { DumpParsedAst.hs:15:13-14 })) + ,(AddEpAnn AnnOpenP (EpaSpan { DumpParsedAst.hs:15:10 })) + ,(AddEpAnn AnnCloseP (EpaSpan { DumpParsedAst.hs:15:17 }))] (EpaComments [])) (()) @@ -534,10 +534,10 @@ (Anchor { DumpParsedAst.hs:15:1-29 } (UnchangedAnchor)) - [(AddEpAnn AnnData (AR { DumpParsedAst.hs:15:1-4 })) - ,(AddEpAnn AnnEqual (AR { DumpParsedAst.hs:15:19 })) - ,(AddEpAnn AnnCloseP (AR { DumpParsedAst.hs:15:17 })) - ,(AddEpAnn AnnOpenP (AR { DumpParsedAst.hs:15:10 }))] + [(AddEpAnn AnnData (EpaSpan { DumpParsedAst.hs:15:1-4 })) + ,(AddEpAnn AnnEqual (EpaSpan { DumpParsedAst.hs:15:19 })) + ,(AddEpAnn AnnCloseP (EpaSpan { DumpParsedAst.hs:15:17 })) + ,(AddEpAnn AnnOpenP (EpaSpan { DumpParsedAst.hs:15:10 }))] (EpaComments [])) (DataType) @@ -576,8 +576,8 @@ (UnchangedAnchor)) (AnnParen (AnnParens) - (AR { DumpParsedAst.hs:15:25 }) - (AR { DumpParsedAst.hs:15:29 })) + (EpaSpan { DumpParsedAst.hs:15:25 }) + (EpaSpan { DumpParsedAst.hs:15:29 })) (EpaComments [])) (L @@ -634,14 +634,14 @@ (Anchor { DumpParsedAst.hs:17:1-54 } (UnchangedAnchor)) - [(AddEpAnn AnnType (AR { DumpParsedAst.hs:17:1-4 })) - ,(AddEpAnn AnnFamily (AR { DumpParsedAst.hs:17:6-11 })) - ,(AddEpAnn AnnDcolon (AR { DumpParsedAst.hs:17:42-43 })) - ,(AddEpAnn AnnWhere (AR { DumpParsedAst.hs:17:50-54 })) - ,(AddEpAnn AnnCloseP (AR { DumpParsedAst.hs:17:23 })) - ,(AddEpAnn AnnOpenP (AR { DumpParsedAst.hs:17:16 })) - ,(AddEpAnn AnnCloseP (AR { DumpParsedAst.hs:17:40 })) - ,(AddEpAnn AnnOpenP (AR { DumpParsedAst.hs:17:25 }))] + [(AddEpAnn AnnType (EpaSpan { DumpParsedAst.hs:17:1-4 })) + ,(AddEpAnn AnnFamily (EpaSpan { DumpParsedAst.hs:17:6-11 })) + ,(AddEpAnn AnnDcolon (EpaSpan { DumpParsedAst.hs:17:42-43 })) + ,(AddEpAnn AnnWhere (EpaSpan { DumpParsedAst.hs:17:50-54 })) + ,(AddEpAnn AnnCloseP (EpaSpan { DumpParsedAst.hs:17:23 })) + ,(AddEpAnn AnnOpenP (EpaSpan { DumpParsedAst.hs:17:16 })) + ,(AddEpAnn AnnCloseP (EpaSpan { DumpParsedAst.hs:17:40 })) + ,(AddEpAnn AnnOpenP (EpaSpan { DumpParsedAst.hs:17:25 }))] (EpaComments [])) (ClosedTypeFamily @@ -653,7 +653,7 @@ (Anchor { DumpParsedAst.hs:18:3-30 } (UnchangedAnchor)) - [(AddEpAnn AnnEqual (AR { DumpParsedAst.hs:18:17 }))] + [(AddEpAnn AnnEqual (EpaSpan { DumpParsedAst.hs:18:17 }))] (EpaComments [])) (L @@ -798,9 +798,9 @@ (Anchor { DumpParsedAst.hs:17:16-23 } (UnchangedAnchor)) - [(AddEpAnn AnnDcolon (AR { DumpParsedAst.hs:17:19-20 })) - ,(AddEpAnn AnnOpenP (AR { DumpParsedAst.hs:17:16 })) - ,(AddEpAnn AnnCloseP (AR { DumpParsedAst.hs:17:23 }))] + [(AddEpAnn AnnDcolon (EpaSpan { DumpParsedAst.hs:17:19-20 })) + ,(AddEpAnn AnnOpenP (EpaSpan { DumpParsedAst.hs:17:16 })) + ,(AddEpAnn AnnCloseP (EpaSpan { DumpParsedAst.hs:17:23 }))] (EpaComments [])) (()) @@ -830,9 +830,9 @@ (Anchor { DumpParsedAst.hs:17:25-40 } (UnchangedAnchor)) - [(AddEpAnn AnnDcolon (AR { DumpParsedAst.hs:17:28-29 })) - ,(AddEpAnn AnnOpenP (AR { DumpParsedAst.hs:17:25 })) - ,(AddEpAnn AnnCloseP (AR { DumpParsedAst.hs:17:40 }))] + [(AddEpAnn AnnDcolon (EpaSpan { DumpParsedAst.hs:17:28-29 })) + ,(AddEpAnn AnnOpenP (EpaSpan { DumpParsedAst.hs:17:25 })) + ,(AddEpAnn AnnCloseP (EpaSpan { DumpParsedAst.hs:17:40 }))] (EpaComments [])) (()) @@ -848,7 +848,7 @@ { DumpParsedAst.hs:17:31 } (UnchangedAnchor)) (AddRarrowAnn - (AR { DumpParsedAst.hs:17:33-34 })) + (EpaSpan { DumpParsedAst.hs:17:33-34 })) (EpaComments [])) (HsUnrestrictedArrow @@ -954,7 +954,7 @@ (UnchangedAnchor)) (GrhsAnn (Nothing) - (AddEpAnn AnnEqual (AR { DumpParsedAst.hs:20:6 }))) + (AddEpAnn AnnEqual (EpaSpan { DumpParsedAst.hs:20:6 }))) (EpaComments [])) [] @@ -994,4 +994,4 @@ (FromSource)) [])))] (Nothing) - (Nothing))) + (Nothing)))
\ No newline at end of file diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr index f131c08880..c41d01d452 100644 --- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr @@ -119,7 +119,7 @@ (UnchangedAnchor)) (AnnListItem [(AddVbarAnn - (AR { DumpRenamedAst.hs:10:19 }))]) + (EpaSpan { DumpRenamedAst.hs:10:19 }))]) (EpaComments [])) { DumpRenamedAst.hs:10:14-17 }) (ConDeclH98 @@ -293,9 +293,9 @@ (Anchor { DumpRenamedAst.hs:12:20-30 } (UnchangedAnchor)) - [(AddEpAnn AnnDcolon (AR { DumpRenamedAst.hs:12:24-25 })) - ,(AddEpAnn AnnOpenP (AR { DumpRenamedAst.hs:12:20 })) - ,(AddEpAnn AnnCloseP (AR { DumpRenamedAst.hs:12:30 }))] + [(AddEpAnn AnnDcolon (EpaSpan { DumpRenamedAst.hs:12:24-25 })) + ,(AddEpAnn AnnOpenP (EpaSpan { DumpRenamedAst.hs:12:20 })) + ,(AddEpAnn AnnCloseP (EpaSpan { DumpRenamedAst.hs:12:30 }))] (EpaComments [])) (()) @@ -311,8 +311,8 @@ (UnchangedAnchor)) (AnnParen (AnnParensSquare) - (AR { DumpRenamedAst.hs:12:27 }) - (AR { DumpRenamedAst.hs:12:29 })) + (EpaSpan { DumpRenamedAst.hs:12:27 }) + (EpaSpan { DumpRenamedAst.hs:12:29 })) (EpaComments [])) (L @@ -376,7 +376,7 @@ { DumpRenamedAst.hs:16:20 } (UnchangedAnchor)) (AddRarrowAnn - (AR { DumpRenamedAst.hs:16:22-23 })) + (EpaSpan { DumpRenamedAst.hs:16:22-23 })) (EpaComments [])) (HsUnrestrictedArrow @@ -397,7 +397,7 @@ { DumpRenamedAst.hs:16:25 } (UnchangedAnchor)) (AddRarrowAnn - (AR { DumpRenamedAst.hs:16:27-28 })) + (EpaSpan { DumpRenamedAst.hs:16:27-28 })) (EpaComments [])) (HsUnrestrictedArrow @@ -453,7 +453,7 @@ (Anchor { DumpRenamedAst.hs:19:23 } (UnchangedAnchor)) - [(AddEpAnn AnnDcolon (AR { DumpRenamedAst.hs:19:25-26 }))] + [(AddEpAnn AnnDcolon (EpaSpan { DumpRenamedAst.hs:19:25-26 }))] (EpaComments [])) (L @@ -472,7 +472,7 @@ { DumpRenamedAst.hs:19:28 } (UnchangedAnchor)) (AddRarrowAnn - (AR { DumpRenamedAst.hs:19:30-31 })) + (EpaSpan { DumpRenamedAst.hs:19:30-31 })) (EpaComments [])) (HsUnrestrictedArrow @@ -508,7 +508,7 @@ { DumpRenamedAst.hs:19:42-52 } (UnchangedAnchor)) (AddRarrowAnn - (AR { DumpRenamedAst.hs:19:54-55 })) + (EpaSpan { DumpRenamedAst.hs:19:54-55 })) (EpaComments [])) (HsUnrestrictedArrow @@ -525,7 +525,7 @@ { DumpRenamedAst.hs:19:43 } (UnchangedAnchor)) (AddRarrowAnn - (AR { DumpRenamedAst.hs:19:45-46 })) + (EpaSpan { DumpRenamedAst.hs:19:45-46 })) (EpaComments [])) (HsUnrestrictedArrow @@ -578,7 +578,7 @@ (UnchangedAnchor)) (AnnListItem [(AddRarrowAnn - (AR { DumpRenamedAst.hs:20:36-37 }))]) + (EpaSpan { DumpRenamedAst.hs:20:36-37 }))]) (EpaComments [])) { DumpRenamedAst.hs:20:10-34 }) (HsParTy @@ -611,7 +611,7 @@ { DumpRenamedAst.hs:20:22-25 } (UnchangedAnchor)) (AddRarrowAnn - (AR { DumpRenamedAst.hs:20:27-28 })) + (EpaSpan { DumpRenamedAst.hs:20:27-28 })) (EpaComments [])) (HsUnrestrictedArrow @@ -733,9 +733,9 @@ (Anchor { DumpRenamedAst.hs:22:10-17 } (UnchangedAnchor)) - [(AddEpAnn AnnDcolon (AR { DumpRenamedAst.hs:22:13-14 })) - ,(AddEpAnn AnnOpenP (AR { DumpRenamedAst.hs:22:10 })) - ,(AddEpAnn AnnCloseP (AR { DumpRenamedAst.hs:22:17 }))] + [(AddEpAnn AnnDcolon (EpaSpan { DumpRenamedAst.hs:22:13-14 })) + ,(AddEpAnn AnnOpenP (EpaSpan { DumpRenamedAst.hs:22:10 })) + ,(AddEpAnn AnnCloseP (EpaSpan { DumpRenamedAst.hs:22:17 }))] (EpaComments [])) (()) @@ -915,9 +915,9 @@ (Anchor { DumpRenamedAst.hs:24:16-23 } (UnchangedAnchor)) - [(AddEpAnn AnnDcolon (AR { DumpRenamedAst.hs:24:19-20 })) - ,(AddEpAnn AnnOpenP (AR { DumpRenamedAst.hs:24:16 })) - ,(AddEpAnn AnnCloseP (AR { DumpRenamedAst.hs:24:23 }))] + [(AddEpAnn AnnDcolon (EpaSpan { DumpRenamedAst.hs:24:19-20 })) + ,(AddEpAnn AnnOpenP (EpaSpan { DumpRenamedAst.hs:24:16 })) + ,(AddEpAnn AnnCloseP (EpaSpan { DumpRenamedAst.hs:24:23 }))] (EpaComments [])) (()) @@ -939,9 +939,9 @@ (Anchor { DumpRenamedAst.hs:24:25-40 } (UnchangedAnchor)) - [(AddEpAnn AnnDcolon (AR { DumpRenamedAst.hs:24:28-29 })) - ,(AddEpAnn AnnOpenP (AR { DumpRenamedAst.hs:24:25 })) - ,(AddEpAnn AnnCloseP (AR { DumpRenamedAst.hs:24:40 }))] + [(AddEpAnn AnnDcolon (EpaSpan { DumpRenamedAst.hs:24:28-29 })) + ,(AddEpAnn AnnOpenP (EpaSpan { DumpRenamedAst.hs:24:25 })) + ,(AddEpAnn AnnCloseP (EpaSpan { DumpRenamedAst.hs:24:40 }))] (EpaComments [])) (()) @@ -956,7 +956,7 @@ { DumpRenamedAst.hs:24:31 } (UnchangedAnchor)) (AddRarrowAnn - (AR { DumpRenamedAst.hs:24:33-34 })) + (EpaSpan { DumpRenamedAst.hs:24:33-34 })) (EpaComments [])) (HsUnrestrictedArrow @@ -1122,8 +1122,8 @@ (UnchangedAnchor)) (AnnParen (AnnParensSquare) - (AR { DumpRenamedAst.hs:30:12 }) - (AR { DumpRenamedAst.hs:30:14 })) + (EpaSpan { DumpRenamedAst.hs:30:12 }) + (EpaSpan { DumpRenamedAst.hs:30:14 })) (EpaComments [])) (L @@ -1144,7 +1144,7 @@ (Anchor { DumpRenamedAst.hs:31:3-27 } (UnchangedAnchor)) - [(AddEpAnn AnnType (AR { DumpRenamedAst.hs:31:3-6 }))] + [(AddEpAnn AnnType (EpaSpan { DumpRenamedAst.hs:31:3-6 }))] (EpaComments [])) (FamEqn @@ -1164,8 +1164,8 @@ (UnchangedAnchor)) (AnnParen (AnnParensSquare) - (AR { DumpRenamedAst.hs:31:10 }) - (AR { DumpRenamedAst.hs:31:12 })) + (EpaSpan { DumpRenamedAst.hs:31:10 }) + (EpaSpan { DumpRenamedAst.hs:31:12 })) (EpaComments [])) (L @@ -1283,9 +1283,9 @@ (AnnList (Nothing) (Just - (AddEpAnn AnnOpenP (AR { DumpRenamedAst.hs:8:18 }))) + (AddEpAnn AnnOpenP (EpaSpan { DumpRenamedAst.hs:8:18 }))) (Just - (AddEpAnn AnnCloseP (AR { DumpRenamedAst.hs:8:23 }))) + (AddEpAnn AnnCloseP (EpaSpan { DumpRenamedAst.hs:8:23 }))) [] []) (EpaComments @@ -1302,5 +1302,3 @@ {Name: GHC.Types.Type})))))])))))] (Nothing) (Nothing))) - - diff --git a/testsuite/tests/parser/should_compile/KindSigs.stderr b/testsuite/tests/parser/should_compile/KindSigs.stderr index 3f477a4bec..f33f08312d 100644 --- a/testsuite/tests/parser/should_compile/KindSigs.stderr +++ b/testsuite/tests/parser/should_compile/KindSigs.stderr @@ -9,8 +9,8 @@ { KindSigs.hs:1:1 } (UnchangedAnchor)) (AnnsModule - [(AddEpAnn AnnModule (AR { KindSigs.hs:6:1-6 })) - ,(AddEpAnn AnnWhere (AR { KindSigs.hs:6:17-21 }))] + [(AddEpAnn AnnModule (EpaSpan { KindSigs.hs:6:1-6 })) + ,(AddEpAnn AnnWhere (EpaSpan { KindSigs.hs:6:17-21 }))] (AnnList (Nothing) (Nothing) @@ -41,7 +41,7 @@ { KindSigs.hs:8:1-6 } (UnchangedAnchor)) (EpAnnImportDecl - (AR { KindSigs.hs:8:1-6 }) + (EpaSpan { KindSigs.hs:8:1-6 }) (Nothing) (Nothing) (Nothing) @@ -78,9 +78,9 @@ (Anchor { KindSigs.hs:11:1-23 } (UnchangedAnchor)) - [(AddEpAnn AnnType (AR { KindSigs.hs:11:1-4 })) - ,(AddEpAnn AnnFamily (AR { KindSigs.hs:11:6-11 })) - ,(AddEpAnn AnnWhere (AR { KindSigs.hs:11:19-23 }))] + [(AddEpAnn AnnType (EpaSpan { KindSigs.hs:11:1-4 })) + ,(AddEpAnn AnnFamily (EpaSpan { KindSigs.hs:11:6-11 })) + ,(AddEpAnn AnnWhere (EpaSpan { KindSigs.hs:11:19-23 }))] (EpaComments [])) (ClosedTypeFamily @@ -92,7 +92,7 @@ (Anchor { KindSigs.hs:12:3-21 } (UnchangedAnchor)) - [(AddEpAnn AnnEqual (AR { KindSigs.hs:12:9 }))] + [(AddEpAnn AnnEqual (EpaSpan { KindSigs.hs:12:9 }))] (EpaComments [])) (L @@ -125,7 +125,7 @@ (Anchor { KindSigs.hs:12:11-13 } (UnchangedAnchor)) - [(AddEpAnn AnnDcolon (AR { KindSigs.hs:12:15-16 }))] + [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:12:15-16 }))] (EpaComments [])) (L @@ -202,8 +202,8 @@ (Anchor { KindSigs.hs:15:1-51 } (UnchangedAnchor)) - [(AddEpAnn AnnType (AR { KindSigs.hs:15:1-4 })) - ,(AddEpAnn AnnEqual (AR { KindSigs.hs:15:12 }))] + [(AddEpAnn AnnType (EpaSpan { KindSigs.hs:15:1-4 })) + ,(AddEpAnn AnnEqual (EpaSpan { KindSigs.hs:15:12 }))] (EpaComments [])) (L @@ -237,8 +237,8 @@ (UnchangedAnchor)) (AnnParen (AnnParens) - (AR { KindSigs.hs:15:14 }) - (AR { KindSigs.hs:15:51 })) + (EpaSpan { KindSigs.hs:15:14 }) + (EpaSpan { KindSigs.hs:15:51 })) (EpaComments [])) (HsBoxedOrConstraintTuple) @@ -249,7 +249,7 @@ (UnchangedAnchor)) (AnnListItem [(AddCommaAnn - (AR { KindSigs.hs:15:27 }))]) + (EpaSpan { KindSigs.hs:15:27 }))]) (EpaComments [])) { KindSigs.hs:15:16-26 }) (HsKindSig @@ -257,7 +257,7 @@ (Anchor { KindSigs.hs:15:16-18 } (UnchangedAnchor)) - [(AddEpAnn AnnDcolon (AR { KindSigs.hs:15:20-21 }))] + [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:15:20-21 }))] (EpaComments [])) (L @@ -297,7 +297,7 @@ (UnchangedAnchor)) (AnnListItem [(AddCommaAnn - (AR { KindSigs.hs:15:33 }))]) + (EpaSpan { KindSigs.hs:15:33 }))]) (EpaComments [])) { KindSigs.hs:15:29-32 }) (HsTyVar @@ -320,7 +320,7 @@ (Anchor { KindSigs.hs:15:35-41 } (UnchangedAnchor)) - [(AddEpAnn AnnDcolon (AR { KindSigs.hs:15:43-44 }))] + [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:15:43-44 }))] (EpaComments [])) (L @@ -388,8 +388,8 @@ (Anchor { KindSigs.hs:16:1-54 } (UnchangedAnchor)) - [(AddEpAnn AnnType (AR { KindSigs.hs:16:1-4 })) - ,(AddEpAnn AnnEqual (AR { KindSigs.hs:16:13 }))] + [(AddEpAnn AnnType (EpaSpan { KindSigs.hs:16:1-4 })) + ,(AddEpAnn AnnEqual (EpaSpan { KindSigs.hs:16:13 }))] (EpaComments [])) (L @@ -423,8 +423,8 @@ (UnchangedAnchor)) (AnnParen (AnnParensHash) - (AR { KindSigs.hs:16:15-16 }) - (AR { KindSigs.hs:16:53-54 })) + (EpaSpan { KindSigs.hs:16:15-16 }) + (EpaSpan { KindSigs.hs:16:53-54 })) (EpaComments [])) (HsUnboxedTuple) @@ -435,7 +435,7 @@ (UnchangedAnchor)) (AnnListItem [(AddCommaAnn - (AR { KindSigs.hs:16:29 }))]) + (EpaSpan { KindSigs.hs:16:29 }))]) (EpaComments [])) { KindSigs.hs:16:18-28 }) (HsKindSig @@ -443,7 +443,7 @@ (Anchor { KindSigs.hs:16:18-20 } (UnchangedAnchor)) - [(AddEpAnn AnnDcolon (AR { KindSigs.hs:16:22-23 }))] + [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:16:22-23 }))] (EpaComments [])) (L @@ -483,7 +483,7 @@ (UnchangedAnchor)) (AnnListItem [(AddCommaAnn - (AR { KindSigs.hs:16:35 }))]) + (EpaSpan { KindSigs.hs:16:35 }))]) (EpaComments [])) { KindSigs.hs:16:31-34 }) (HsTyVar @@ -506,7 +506,7 @@ (Anchor { KindSigs.hs:16:37-43 } (UnchangedAnchor)) - [(AddEpAnn AnnDcolon (AR { KindSigs.hs:16:45-46 }))] + [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:16:45-46 }))] (EpaComments [])) (L @@ -574,8 +574,8 @@ (Anchor { KindSigs.hs:19:1-26 } (UnchangedAnchor)) - [(AddEpAnn AnnType (AR { KindSigs.hs:19:1-4 })) - ,(AddEpAnn AnnEqual (AR { KindSigs.hs:19:10 }))] + [(AddEpAnn AnnType (EpaSpan { KindSigs.hs:19:1-4 })) + ,(AddEpAnn AnnEqual (EpaSpan { KindSigs.hs:19:10 }))] (EpaComments [])) (L @@ -595,8 +595,8 @@ (UnchangedAnchor)) (AnnParen (AnnParensSquare) - (AR { KindSigs.hs:19:12 }) - (AR { KindSigs.hs:19:26 })) + (EpaSpan { KindSigs.hs:19:12 }) + (EpaSpan { KindSigs.hs:19:26 })) (EpaComments [])) (L @@ -606,7 +606,7 @@ (Anchor { KindSigs.hs:19:14-16 } (UnchangedAnchor)) - [(AddEpAnn AnnDcolon (AR { KindSigs.hs:19:18-19 }))] + [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:19:18-19 }))] (EpaComments [])) (L @@ -656,7 +656,7 @@ { KindSigs.hs:22:1-3 } (UnchangedAnchor)) (AnnSig - (AddEpAnn AnnDcolon (AR { KindSigs.hs:22:5-6 })) + (AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:22:5-6 })) []) (EpaComments [])) @@ -680,7 +680,7 @@ { KindSigs.hs:22:8-20 } (UnchangedAnchor)) (AddRarrowAnn - (AR { KindSigs.hs:22:22-23 })) + (EpaSpan { KindSigs.hs:22:22-23 })) (EpaComments [])) (HsUnrestrictedArrow @@ -694,8 +694,8 @@ (UnchangedAnchor)) (AnnParen (AnnParens) - (AR { KindSigs.hs:22:8 }) - (AR { KindSigs.hs:22:20 })) + (EpaSpan { KindSigs.hs:22:8 }) + (EpaSpan { KindSigs.hs:22:20 })) (EpaComments [])) (L @@ -705,7 +705,7 @@ (Anchor { KindSigs.hs:22:9-11 } (UnchangedAnchor)) - [(AddEpAnn AnnDcolon (AR { KindSigs.hs:22:13-14 }))] + [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:22:13-14 }))] (EpaComments [])) (L @@ -746,7 +746,7 @@ { KindSigs.hs:22:25-28 } (UnchangedAnchor)) (AddRarrowAnn - (AR { KindSigs.hs:22:30-31 })) + (EpaSpan { KindSigs.hs:22:30-31 })) (EpaComments [])) (HsUnrestrictedArrow @@ -775,8 +775,8 @@ (UnchangedAnchor)) (AnnParen (AnnParens) - (AR { KindSigs.hs:22:33 }) - (AR { KindSigs.hs:22:44 })) + (EpaSpan { KindSigs.hs:22:33 }) + (EpaSpan { KindSigs.hs:22:44 })) (EpaComments [])) (L @@ -786,7 +786,7 @@ (Anchor { KindSigs.hs:22:34-35 } (UnchangedAnchor)) - [(AddEpAnn AnnDcolon (AR { KindSigs.hs:22:37-38 }))] + [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:22:37-38 }))] (EpaComments [])) (L @@ -798,8 +798,8 @@ (UnchangedAnchor)) (AnnParen (AnnParens) - (AR { KindSigs.hs:22:34 }) - (AR { KindSigs.hs:22:35 })) + (EpaSpan { KindSigs.hs:22:34 }) + (EpaSpan { KindSigs.hs:22:35 })) (EpaComments [])) (HsBoxedOrConstraintTuple) @@ -876,7 +876,7 @@ (UnchangedAnchor)) (GrhsAnn (Nothing) - (AddEpAnn AnnEqual (AR { KindSigs.hs:23:9 }))) + (AddEpAnn AnnEqual (EpaSpan { KindSigs.hs:23:9 }))) (EpaComments [])) [] @@ -891,8 +891,8 @@ (UnchangedAnchor)) (NameAnnOnly (NameParens) - (AR { KindSigs.hs:23:11 }) - (AR { KindSigs.hs:23:12 }) + (EpaSpan { KindSigs.hs:23:11 }) + (EpaSpan { KindSigs.hs:23:12 }) []) (EpaComments [])) { KindSigs.hs:23:11-12 }) @@ -918,8 +918,8 @@ (Anchor { KindSigs.hs:26:1-29 } (UnchangedAnchor)) - [(AddEpAnn AnnType (AR { KindSigs.hs:26:1-4 })) - ,(AddEpAnn AnnEqual (AR { KindSigs.hs:26:11 }))] + [(AddEpAnn AnnType (EpaSpan { KindSigs.hs:26:1-4 })) + ,(AddEpAnn AnnEqual (EpaSpan { KindSigs.hs:26:11 }))] (EpaComments [])) (L @@ -937,9 +937,9 @@ (Anchor { KindSigs.hs:26:13 } (UnchangedAnchor)) - [(AddEpAnn AnnSimpleQuote (AR { KindSigs.hs:26:13 })) - ,(AddEpAnn AnnOpenS (AR { KindSigs.hs:26:14 })) - ,(AddEpAnn AnnCloseS (AR { KindSigs.hs:26:29 }))] + [(AddEpAnn AnnSimpleQuote (EpaSpan { KindSigs.hs:26:13 })) + ,(AddEpAnn AnnOpenS (EpaSpan { KindSigs.hs:26:14 })) + ,(AddEpAnn AnnCloseS (EpaSpan { KindSigs.hs:26:29 }))] (EpaComments [])) (IsPromoted) @@ -950,7 +950,7 @@ (Anchor { KindSigs.hs:26:16-19 } (UnchangedAnchor)) - [(AddEpAnn AnnDcolon (AR { KindSigs.hs:26:21-22 }))] + [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:26:21-22 }))] (EpaComments [])) (L @@ -999,8 +999,8 @@ (Anchor { KindSigs.hs:27:1-45 } (UnchangedAnchor)) - [(AddEpAnn AnnType (AR { KindSigs.hs:27:1-4 })) - ,(AddEpAnn AnnEqual (AR { KindSigs.hs:27:12 }))] + [(AddEpAnn AnnType (EpaSpan { KindSigs.hs:27:1-4 })) + ,(AddEpAnn AnnEqual (EpaSpan { KindSigs.hs:27:12 }))] (EpaComments [])) (L @@ -1018,8 +1018,8 @@ (Anchor { KindSigs.hs:27:14 } (UnchangedAnchor)) - [(AddEpAnn AnnOpenS (AR { KindSigs.hs:27:14 })) - ,(AddEpAnn AnnCloseS (AR { KindSigs.hs:27:45 }))] + [(AddEpAnn AnnOpenS (EpaSpan { KindSigs.hs:27:14 })) + ,(AddEpAnn AnnCloseS (EpaSpan { KindSigs.hs:27:45 }))] (EpaComments [])) (NotPromoted) @@ -1030,7 +1030,7 @@ (UnchangedAnchor)) (AnnListItem [(AddCommaAnn - (AR { KindSigs.hs:27:28 }))]) + (EpaSpan { KindSigs.hs:27:28 }))]) (EpaComments [])) { KindSigs.hs:27:16-27 }) (HsKindSig @@ -1038,7 +1038,7 @@ (Anchor { KindSigs.hs:27:16-19 } (UnchangedAnchor)) - [(AddEpAnn AnnDcolon (AR { KindSigs.hs:27:21-22 }))] + [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:27:21-22 }))] (EpaComments [])) (L @@ -1078,7 +1078,7 @@ (Anchor { KindSigs.hs:27:30-34 } (UnchangedAnchor)) - [(AddEpAnn AnnDcolon (AR { KindSigs.hs:27:36-37 }))] + [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:27:36-37 }))] (EpaComments [])) (L @@ -1127,8 +1127,8 @@ (Anchor { KindSigs.hs:28:1-44 } (UnchangedAnchor)) - [(AddEpAnn AnnType (AR { KindSigs.hs:28:1-4 })) - ,(AddEpAnn AnnEqual (AR { KindSigs.hs:28:14 }))] + [(AddEpAnn AnnType (EpaSpan { KindSigs.hs:28:1-4 })) + ,(AddEpAnn AnnEqual (EpaSpan { KindSigs.hs:28:14 }))] (EpaComments [])) (L @@ -1160,9 +1160,9 @@ (Anchor { KindSigs.hs:28:16 } (UnchangedAnchor)) - [(AddEpAnn AnnSimpleQuote (AR { KindSigs.hs:28:16 })) - ,(AddEpAnn AnnOpenP (AR { KindSigs.hs:28:17 })) - ,(AddEpAnn AnnCloseP (AR { KindSigs.hs:28:44 }))] + [(AddEpAnn AnnSimpleQuote (EpaSpan { KindSigs.hs:28:16 })) + ,(AddEpAnn AnnOpenP (EpaSpan { KindSigs.hs:28:17 })) + ,(AddEpAnn AnnCloseP (EpaSpan { KindSigs.hs:28:44 }))] (EpaComments [])) [(L @@ -1172,7 +1172,7 @@ (UnchangedAnchor)) (AnnListItem [(AddCommaAnn - (AR { KindSigs.hs:28:40 }))]) + (EpaSpan { KindSigs.hs:28:40 }))]) (EpaComments [])) { KindSigs.hs:28:19-39 }) (HsKindSig @@ -1180,7 +1180,7 @@ (Anchor { KindSigs.hs:28:19-29 } (UnchangedAnchor)) - [(AddEpAnn AnnDcolon (AR { KindSigs.hs:28:31-32 }))] + [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:28:31-32 }))] (EpaComments [])) (L @@ -1190,8 +1190,8 @@ (Anchor { KindSigs.hs:28:19 } (UnchangedAnchor)) - [(AddEpAnn AnnOpenS (AR { KindSigs.hs:28:19 })) - ,(AddEpAnn AnnCloseS (AR { KindSigs.hs:28:29 }))] + [(AddEpAnn AnnOpenS (EpaSpan { KindSigs.hs:28:19 })) + ,(AddEpAnn AnnCloseS (EpaSpan { KindSigs.hs:28:29 }))] (EpaComments [])) (NotPromoted) @@ -1202,7 +1202,7 @@ (UnchangedAnchor)) (AnnListItem [(AddCommaAnn - (AR { KindSigs.hs:28:23 }))]) + (EpaSpan { KindSigs.hs:28:23 }))]) (EpaComments [])) { KindSigs.hs:28:20-22 }) (HsTyVar @@ -1242,8 +1242,8 @@ (UnchangedAnchor)) (AnnParen (AnnParensSquare) - (AR { KindSigs.hs:28:34 }) - (AR { KindSigs.hs:28:39 })) + (EpaSpan { KindSigs.hs:28:34 }) + (EpaSpan { KindSigs.hs:28:39 })) (EpaComments [])) (L @@ -1292,8 +1292,8 @@ (Anchor { KindSigs.hs:31:1-31 } (UnchangedAnchor)) - [(AddEpAnn AnnType (AR { KindSigs.hs:31:1-4 })) - ,(AddEpAnn AnnEqual (AR { KindSigs.hs:31:19 }))] + [(AddEpAnn AnnType (EpaSpan { KindSigs.hs:31:1-4 })) + ,(AddEpAnn AnnEqual (EpaSpan { KindSigs.hs:31:19 }))] (EpaComments [])) (L @@ -1311,7 +1311,7 @@ (Anchor { KindSigs.hs:31:21-23 } (UnchangedAnchor)) - [(AddEpAnn AnnDcolon (AR { KindSigs.hs:31:25-26 }))] + [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:31:25-26 }))] (EpaComments [])) (L @@ -1361,7 +1361,7 @@ { KindSigs.hs:34:1-4 } (UnchangedAnchor)) (AnnSig - (AddEpAnn AnnDcolon (AR { KindSigs.hs:34:6-7 })) + (AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:34:6-7 })) []) (EpaComments [])) @@ -1386,8 +1386,8 @@ (UnchangedAnchor)) (AnnParen (AnnParens) - (AR { KindSigs.hs:34:9 }) - (AR { KindSigs.hs:34:22 })) + (EpaSpan { KindSigs.hs:34:9 }) + (EpaSpan { KindSigs.hs:34:22 })) (EpaComments [])) (L @@ -1397,7 +1397,7 @@ (Anchor { KindSigs.hs:34:10-13 } (UnchangedAnchor)) - [(AddEpAnn AnnDcolon (AR { KindSigs.hs:34:15-16 }))] + [(AddEpAnn AnnDcolon (EpaSpan { KindSigs.hs:34:15-16 }))] (EpaComments [])) (L @@ -1480,7 +1480,7 @@ (UnchangedAnchor)) (GrhsAnn (Nothing) - (AddEpAnn AnnEqual (AR { KindSigs.hs:35:6 }))) + (AddEpAnn AnnEqual (EpaSpan { KindSigs.hs:35:6 }))) (EpaComments [])) [] diff --git a/testsuite/tests/parser/should_compile/T14189.stderr b/testsuite/tests/parser/should_compile/T14189.stderr index c1ebd053ac..5871c41b1c 100644 --- a/testsuite/tests/parser/should_compile/T14189.stderr +++ b/testsuite/tests/parser/should_compile/T14189.stderr @@ -46,7 +46,7 @@ (UnchangedAnchor)) (AnnListItem [(AddVbarAnn - (AR { T14189.hs:6:22 }))]) + (EpaSpan { T14189.hs:6:22 }))]) (EpaComments [])) { T14189.hs:6:15-20 }) (ConDeclH98 @@ -79,7 +79,7 @@ (UnchangedAnchor)) (AnnListItem [(AddVbarAnn - (AR { T14189.hs:6:27 }))]) + (EpaSpan { T14189.hs:6:27 }))]) (EpaComments [])) { T14189.hs:6:24-25 }) (ConDeclH98 @@ -116,9 +116,9 @@ { T14189.hs:6:33-40 } (UnchangedAnchor))) (Just - (AddEpAnn AnnOpenC (AR { T14189.hs:6:31 }))) + (AddEpAnn AnnOpenC (EpaSpan { T14189.hs:6:31 }))) (Just - (AddEpAnn AnnCloseC (AR { T14189.hs:6:42 }))) + (AddEpAnn AnnCloseC (EpaSpan { T14189.hs:6:42 }))) [] []) (EpaComments @@ -210,3 +210,4 @@ (FieldSelectors) {Name: T14189.f}))])])]) (Nothing))) + diff --git a/testsuite/tests/parser/should_compile/T15323.stderr b/testsuite/tests/parser/should_compile/T15323.stderr index e91ff5b3f4..987a5b88a6 100644 --- a/testsuite/tests/parser/should_compile/T15323.stderr +++ b/testsuite/tests/parser/should_compile/T15323.stderr @@ -9,8 +9,8 @@ { T15323.hs:1:1 } (UnchangedAnchor)) (AnnsModule - [(AddEpAnn AnnModule (AR { T15323.hs:3:1-6 })) - ,(AddEpAnn AnnWhere (AR { T15323.hs:3:15-19 }))] + [(AddEpAnn AnnModule (EpaSpan { T15323.hs:3:1-6 })) + ,(AddEpAnn AnnWhere (EpaSpan { T15323.hs:3:15-19 }))] (AnnList (Nothing) (Nothing) @@ -50,8 +50,8 @@ (Anchor { T15323.hs:(5,1)-(6,54) } (UnchangedAnchor)) - [(AddEpAnn AnnData (AR { T15323.hs:5:1-4 })) - ,(AddEpAnn AnnWhere (AR { T15323.hs:5:21-25 }))] + [(AddEpAnn AnnData (EpaSpan { T15323.hs:5:1-4 })) + ,(AddEpAnn AnnWhere (EpaSpan { T15323.hs:5:21-25 }))] (EpaComments [])) (L @@ -81,8 +81,8 @@ (Anchor { T15323.hs:(5,1)-(6,54) } (UnchangedAnchor)) - [(AddEpAnn AnnData (AR { T15323.hs:5:1-4 })) - ,(AddEpAnn AnnWhere (AR { T15323.hs:5:21-25 }))] + [(AddEpAnn AnnData (EpaSpan { T15323.hs:5:1-4 })) + ,(AddEpAnn AnnWhere (EpaSpan { T15323.hs:5:21-25 }))] (EpaComments [])) (DataType) @@ -96,7 +96,7 @@ (Anchor { T15323.hs:6:5-54 } (UnchangedAnchor)) - [(AddEpAnn AnnDcolon (AR { T15323.hs:6:17-18 }))] + [(AddEpAnn AnnDcolon (EpaSpan { T15323.hs:6:17-18 }))] (EpaComments [])) [(L @@ -111,8 +111,8 @@ { T15323.hs:6:20-25 } (UnchangedAnchor)) ((,) - (AddEpAnn AnnForall (AR { T15323.hs:6:20-25 })) - (AddEpAnn AnnDot (AR { T15323.hs:6:29 }))) + (AddEpAnn AnnForall (EpaSpan { T15323.hs:6:20-25 })) + (AddEpAnn AnnDot (EpaSpan { T15323.hs:6:29 }))) (EpaComments [])) [(L @@ -140,7 +140,7 @@ (Just ((,) (NormalSyntax) - (AR { T15323.hs:6:38-39 }))) + (EpaSpan { T15323.hs:6:38-39 }))) [] []) (EpaComments @@ -154,8 +154,8 @@ (UnchangedAnchor)) (AnnParen (AnnParens) - (AR { T15323.hs:6:31 }) - (AR { T15323.hs:6:36 })) + (EpaSpan { T15323.hs:6:31 }) + (EpaSpan { T15323.hs:6:36 })) (EpaComments [])) (L diff --git a/testsuite/tests/printer/T18791.stderr b/testsuite/tests/printer/T18791.stderr index 4787c0b8db..3ff58cc17e 100644 --- a/testsuite/tests/printer/T18791.stderr +++ b/testsuite/tests/printer/T18791.stderr @@ -1,6 +1,7 @@ ==================== Parser AST ==================== + (L { T18791.hs:1:1 } (HsModule @@ -9,8 +10,8 @@ { T18791.hs:1:1 } (UnchangedAnchor)) (AnnsModule - [(AddEpAnn AnnModule (AR { T18791.hs:2:1-6 })) - ,(AddEpAnn AnnWhere (AR { T18791.hs:2:15-19 }))] + [(AddEpAnn AnnModule (EpaSpan { T18791.hs:2:1-6 })) + ,(AddEpAnn AnnWhere (EpaSpan { T18791.hs:2:15-19 }))] (AnnList (Nothing) (Nothing) @@ -50,8 +51,8 @@ (Anchor { T18791.hs:(4,1)-(5,17) } (UnchangedAnchor)) - [(AddEpAnn AnnData (AR { T18791.hs:4:1-4 })) - ,(AddEpAnn AnnWhere (AR { T18791.hs:4:8-12 }))] + [(AddEpAnn AnnData (EpaSpan { T18791.hs:4:1-4 })) + ,(AddEpAnn AnnWhere (EpaSpan { T18791.hs:4:8-12 }))] (EpaComments [])) (L @@ -67,8 +68,8 @@ (Anchor { T18791.hs:(4,1)-(5,17) } (UnchangedAnchor)) - [(AddEpAnn AnnData (AR { T18791.hs:4:1-4 })) - ,(AddEpAnn AnnWhere (AR { T18791.hs:4:8-12 }))] + [(AddEpAnn AnnData (EpaSpan { T18791.hs:4:1-4 })) + ,(AddEpAnn AnnWhere (EpaSpan { T18791.hs:4:8-12 }))] (EpaComments [])) (DataType) @@ -82,7 +83,7 @@ (Anchor { T18791.hs:5:3-17 } (UnchangedAnchor)) - [(AddEpAnn AnnDcolon (AR { T18791.hs:5:7-8 }))] + [(AddEpAnn AnnDcolon (EpaSpan { T18791.hs:5:7-8 }))] (EpaComments [])) [(L @@ -105,7 +106,7 @@ (UnchangedAnchor)) (AnnListItem [(AddRarrowAnn - (AR { T18791.hs:5:14-15 }))]) + (EpaSpan { T18791.hs:5:14-15 }))]) (EpaComments [])) { T18791.hs:5:10-12 }) (HsTyVar diff --git a/testsuite/tests/quasiquotation/Makefile b/testsuite/tests/quasiquotation/Makefile index 76e8a928fb..9a9db1ead9 100644 --- a/testsuite/tests/quasiquotation/Makefile +++ b/testsuite/tests/quasiquotation/Makefile @@ -11,5 +11,5 @@ T4150: T14028: '$(TEST_HC)' $(TEST_HC_OPTS) -v0 T14028Quote.hs - '$(TEST_HC)' $(TEST_HC_OPTS) -v0 -c T14028C.c + '$(TEST_HC)' $(TEST_HC_OPTS) -v0 -fPIC -c T14028C.c '$(TEST_HC)' $(TEST_HC_OPTS) -v0 -fexternal-interpreter T14028 T14028C.o diff --git a/testsuite/tests/quasiquotation/all.T b/testsuite/tests/quasiquotation/all.T index 0d2fd713cb..e8b3bd1e6f 100644 --- a/testsuite/tests/quasiquotation/all.T +++ b/testsuite/tests/quasiquotation/all.T @@ -9,6 +9,5 @@ test('T14028', [req_interp, req_rts_linker, only_ways([config.ghc_th_way]), unless(config.have_ext_interp, skip), - when(opsys('linux') and arch('arm'), expect_broken_for(17558, ['dyn'])), - when(opsys('linux') and arch('x86_64'), expect_broken_for(17300, ['dyn']))], + when(opsys('freebsd'), expect_broken(19723))], makefile_test, ['T14028']) diff --git a/testsuite/tests/simplCore/should_compile/T13143.stderr b/testsuite/tests/simplCore/should_compile/T13143.stderr index 86094fe7d9..87fbdd6213 100644 --- a/testsuite/tests/simplCore/should_compile/T13143.stderr +++ b/testsuite/tests/simplCore/should_compile/T13143.stderr @@ -97,14 +97,14 @@ g [InlPrag=[2]] :: Bool -> Bool -> Int -> Int Tmpl= \ (w [Occ=Once1] :: Bool) (w1 [Occ=Once1] :: Bool) (w2 [Occ=Once1!] :: Int) -> - case w2 of { GHC.Types.I# ww1 [Occ=Once1] -> - case T13143.$wg w w1 ww1 of ww2 [Occ=Once1] { __DEFAULT -> - GHC.Types.I# ww2 + case w2 of { GHC.Types.I# ww [Occ=Once1] -> + case T13143.$wg w w1 ww of ww1 [Occ=Once1] { __DEFAULT -> + GHC.Types.I# ww1 } }}] g = \ (w :: Bool) (w1 :: Bool) (w2 :: Int) -> - case w2 of { GHC.Types.I# ww1 -> - case T13143.$wg w w1 ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 } + case w2 of { GHC.Types.I# ww -> + case T13143.$wg w w1 ww of ww1 { __DEFAULT -> GHC.Types.I# ww1 } } diff --git a/testsuite/tests/simplCore/should_compile/T15631.stdout b/testsuite/tests/simplCore/should_compile/T15631.stdout index cce6777d74..e9e6a2bcab 100644 --- a/testsuite/tests/simplCore/should_compile/T15631.stdout +++ b/testsuite/tests/simplCore/should_compile/T15631.stdout @@ -1,7 +1,7 @@ case GHC.List.$wlenAcc - case GHC.List.$wlenAcc @a w 0# of ww2 { __DEFAULT -> + case GHC.List.$wlenAcc @a w 0# of ww1 { __DEFAULT -> case GHC.List.reverse1 @a w (GHC.Types.[] @a) of { - [] -> case Foo.f1 @a of { GHC.Types.I# v1 -> GHC.Prim.+# ww2 v1 }; + [] -> case Foo.f1 @a of { GHC.Types.I# v1 -> GHC.Prim.+# ww1 v1 }; case GHC.List.$wlenAcc case Foo.$wf @a w of ww [Occ=Once1] { __DEFAULT -> case Foo.$wf @a w of ww { __DEFAULT -> GHC.Types.I# ww } diff --git a/testsuite/tests/simplCore/should_compile/T18013.stderr b/testsuite/tests/simplCore/should_compile/T18013.stderr index abcf710083..70998aecf8 100644 --- a/testsuite/tests/simplCore/should_compile/T18013.stderr +++ b/testsuite/tests/simplCore/should_compile/T18013.stderr @@ -141,21 +141,21 @@ mapMaybeRule [InlPrag=[2]] WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) Tmpl= \ (@a) (@b) (w [Occ=Once1!] :: Rule IO a b) -> - case w of { Rule @s ww1 ww2 [Occ=OnceL1!] -> + case w of { Rule @s ww ww1 [Occ=OnceL1!] -> T18013a.Rule @IO @(Maybe a) @(Maybe b) @s - ww1 + ww ((\ (s2 [Occ=Once1] :: s) (a1 [Occ=Once1!] :: Maybe a) (s1 [Occ=Once2] :: GHC.Prim.State# GHC.Prim.RealWorld) -> case a1 of { Nothing -> - (# s1, T18013a.Result @s @(Maybe b) ww1 (GHC.Maybe.Nothing @b) #); + (# s1, T18013a.Result @s @(Maybe b) ww (GHC.Maybe.Nothing @b) #); Just x [Occ=Once1] -> - case ((ww2 s2 x) `cast` <Co:4>) s1 of + case ((ww1 s2 x) `cast` <Co:4>) s1 of { (# ipv [Occ=Once1], ipv1 [Occ=Once1!] #) -> case ipv1 of { Result t2 [Occ=Once1] c1 [Occ=Once1] -> (# ipv, T18013a.Result @s @(Maybe b) t2 (GHC.Maybe.Just @b c1) #) @@ -166,24 +166,24 @@ mapMaybeRule [InlPrag=[2]] }}] mapMaybeRule = \ (@a) (@b) (w :: Rule IO a b) -> - case w of { Rule @s ww1 ww2 -> + case w of { Rule @s ww ww1 -> let { lvl :: Result s (Maybe b) [LclId, Unf=OtherCon []] - lvl = T18013a.Result @s @(Maybe b) ww1 (GHC.Maybe.Nothing @b) } in + lvl = T18013a.Result @s @(Maybe b) ww (GHC.Maybe.Nothing @b) } in T18013a.Rule @IO @(Maybe a) @(Maybe b) @s - ww1 + ww ((\ (s2 :: s) (a1 :: Maybe a) (s1 :: GHC.Prim.State# GHC.Prim.RealWorld) -> case a1 of { Nothing -> (# s1, lvl #); Just x -> - case ((ww2 s2 x) `cast` <Co:4>) s1 of { (# ipv, ipv1 #) -> + case ((ww1 s2 x) `cast` <Co:4>) s1 of { (# ipv, ipv1 #) -> case ipv1 of { Result t2 c1 -> (# ipv, T18013a.Result @s @(Maybe b) t2 (GHC.Maybe.Just @b c1) #) } diff --git a/testsuite/tests/simplCore/should_compile/T19672.hs b/testsuite/tests/simplCore/should_compile/T19672.hs new file mode 100644 index 0000000000..e1f70f2b43 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T19672.hs @@ -0,0 +1,7 @@ +module Foo where + +wimwam :: [a] -> Int -> Int +wimwam [] x = x +wimwam (y:ys) x = wimwam ys 0 + +bar xs = map (wimwam [True]) xs diff --git a/testsuite/tests/simplCore/should_compile/T19672.stderr b/testsuite/tests/simplCore/should_compile/T19672.stderr new file mode 100644 index 0000000000..56b7c18fa9 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T19672.stderr @@ -0,0 +1,8 @@ + +==================== Tidy Core rules ==================== +"SC:wimwam0" + forall (sc :: Bool) (sc1 :: [Bool]). + wimwam @Bool (: @Bool sc sc1) + = bar_$swimwam sc sc1 + + diff --git a/testsuite/tests/simplCore/should_compile/T3717.stderr b/testsuite/tests/simplCore/should_compile/T3717.stderr index f33b8ec401..6e8fe19294 100644 --- a/testsuite/tests/simplCore/should_compile/T3717.stderr +++ b/testsuite/tests/simplCore/should_compile/T3717.stderr @@ -62,15 +62,15 @@ foo [InlPrag=[2]] :: Int -> Int WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) Tmpl= \ (w [Occ=Once1!] :: Int) -> - case w of { GHC.Types.I# ww1 [Occ=Once1] -> - case T3717.$wfoo ww1 of ww2 [Occ=Once1] { __DEFAULT -> - GHC.Types.I# ww2 + case w of { GHC.Types.I# ww [Occ=Once1] -> + case T3717.$wfoo ww of ww1 [Occ=Once1] { __DEFAULT -> + GHC.Types.I# ww1 } }}] foo = \ (w :: Int) -> - case w of { GHC.Types.I# ww1 -> - case T3717.$wfoo ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 } + case w of { GHC.Types.I# ww -> + case T3717.$wfoo ww of ww1 { __DEFAULT -> GHC.Types.I# ww1 } } diff --git a/testsuite/tests/simplCore/should_compile/T3772.stdout b/testsuite/tests/simplCore/should_compile/T3772.stdout index b37882484c..5ead45f9c3 100644 --- a/testsuite/tests/simplCore/should_compile/T3772.stdout +++ b/testsuite/tests/simplCore/should_compile/T3772.stdout @@ -70,9 +70,9 @@ foo [InlPrag=[final]] :: Int -> () WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) Tmpl= \ (w [Occ=Once1!] :: Int) -> - case w of { GHC.Types.I# ww1 [Occ=Once1] -> T3772.$wfoo ww1 }}] + case w of { GHC.Types.I# ww [Occ=Once1] -> T3772.$wfoo ww }}] foo - = \ (w :: Int) -> case w of { GHC.Types.I# ww1 -> T3772.$wfoo ww1 } + = \ (w :: Int) -> case w of { GHC.Types.I# ww -> T3772.$wfoo ww } diff --git a/testsuite/tests/simplCore/should_compile/T4908.stderr b/testsuite/tests/simplCore/should_compile/T4908.stderr index f005d660c8..f8f9107485 100644 --- a/testsuite/tests/simplCore/should_compile/T4908.stderr +++ b/testsuite/tests/simplCore/should_compile/T4908.stderr @@ -86,9 +86,9 @@ f [InlPrag=[2]] :: Int -> (Int, Int) -> Bool WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False) Tmpl= \ (w [Occ=Once1!] :: Int) (w1 [Occ=Once1] :: (Int, Int)) -> - case w of { I# ww1 [Occ=Once1] -> T4908.$wf ww1 w1 }}] + case w of { I# ww [Occ=Once1] -> T4908.$wf ww w1 }}] f = \ (w :: Int) (w1 :: (Int, Int)) -> - case w of { I# ww1 -> T4908.$wf ww1 w1 } + case w of { I# ww -> T4908.$wf ww w1 } ------ Local rules for imported ids -------- diff --git a/testsuite/tests/simplCore/should_compile/T4930.stderr b/testsuite/tests/simplCore/should_compile/T4930.stderr index 66d257897e..3321809415 100644 --- a/testsuite/tests/simplCore/should_compile/T4930.stderr +++ b/testsuite/tests/simplCore/should_compile/T4930.stderr @@ -62,15 +62,15 @@ foo [InlPrag=[2]] :: Int -> Int WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False) Tmpl= \ (w [Occ=Once1!] :: Int) -> - case w of { GHC.Types.I# ww1 [Occ=Once1] -> - case T4930.$wfoo ww1 of ww2 [Occ=Once1] { __DEFAULT -> - GHC.Types.I# ww2 + case w of { GHC.Types.I# ww [Occ=Once1] -> + case T4930.$wfoo ww of ww1 [Occ=Once1] { __DEFAULT -> + GHC.Types.I# ww1 } }}] foo = \ (w :: Int) -> - case w of { GHC.Types.I# ww1 -> - case T4930.$wfoo ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 } + case w of { GHC.Types.I# ww -> + case T4930.$wfoo ww of ww1 { __DEFAULT -> GHC.Types.I# ww1 } } diff --git a/testsuite/tests/simplCore/should_compile/T5298.stdout b/testsuite/tests/simplCore/should_compile/T5298.stdout index 370f9776e2..67b106c3be 100644 --- a/testsuite/tests/simplCore/should_compile/T5298.stdout +++ b/testsuite/tests/simplCore/should_compile/T5298.stdout @@ -7,7 +7,7 @@ $wg } -- g = \ w -> - case w of { I# ww1 -> case $wg ww1 of ww2 { __DEFAULT -> I# ww2 } } + case w of { I# ww -> case $wg ww of ww1 { __DEFAULT -> I# ww1 } } ------ Local rules for imported ids -------- diff --git a/testsuite/tests/simplCore/should_compile/T7360.stderr b/testsuite/tests/simplCore/should_compile/T7360.stderr index fe869c7c40..070d7ef7fe 100644 --- a/testsuite/tests/simplCore/should_compile/T7360.stderr +++ b/testsuite/tests/simplCore/should_compile/T7360.stderr @@ -43,15 +43,15 @@ fun2 :: forall {a}. [a] -> ((), Int) Tmpl= \ (@a) (x [Occ=Once1] :: [a]) -> (T7360.fun4, case x of wild [Occ=Once1] { __DEFAULT -> - case GHC.List.$wlenAcc @a wild 0# of ww2 [Occ=Once1] { __DEFAULT -> - GHC.Types.I# ww2 + case GHC.List.$wlenAcc @a wild 0# of ww1 [Occ=Once1] { __DEFAULT -> + GHC.Types.I# ww1 } })}] fun2 = \ (@a) (x :: [a]) -> (T7360.fun4, - case GHC.List.$wlenAcc @a x 0# of ww2 { __DEFAULT -> - GHC.Types.I# ww2 + case GHC.List.$wlenAcc @a x 0# of ww1 { __DEFAULT -> + GHC.Types.I# ww1 }) -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} diff --git a/testsuite/tests/simplCore/should_compile/T7865.stdout b/testsuite/tests/simplCore/should_compile/T7865.stdout index 37bc4157cc..1dd2c25893 100644 --- a/testsuite/tests/simplCore/should_compile/T7865.stdout +++ b/testsuite/tests/simplCore/should_compile/T7865.stdout @@ -1,8 +1,8 @@ T7865.$wexpensive [InlPrag=NOINLINE] T7865.$wexpensive expensive [InlPrag=[final]] :: Int -> Int - case T7865.$wexpensive ww1 of ww2 [Occ=Once1] { __DEFAULT -> + case T7865.$wexpensive ww of ww1 [Occ=Once1] { __DEFAULT -> expensive - case T7865.$wexpensive ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 } - case T7865.$wexpensive ww1 of ww2 { __DEFAULT -> - case T7865.$wexpensive ww1 of ww2 { __DEFAULT -> + case T7865.$wexpensive ww of ww1 { __DEFAULT -> GHC.Types.I# ww1 } + case T7865.$wexpensive ww of ww1 { __DEFAULT -> + case T7865.$wexpensive ww of ww1 { __DEFAULT -> diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index 623da259ef..dba67fa80b 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/testsuite/tests/simplCore/should_compile/all.T @@ -355,3 +355,6 @@ test('T19581', [ grep_errmsg(r'case') ], compile, ['-O -ddump-simpl -dsuppress-u test('T19599', normal, compile, ['-O -ddump-rules']) test('T19599a', normal, compile, ['-O -ddump-rules']) test('T13873', [ grep_errmsg(r'SPEC') ], compile, ['-O -ddump-rules']) + +# Look for a specialisation rule for wimwam +test('T19672', normal, compile, ['-O2 -ddump-rules']) diff --git a/testsuite/tests/simplStg/should_compile/T19717.hs b/testsuite/tests/simplStg/should_compile/T19717.hs new file mode 100644 index 0000000000..2b485b6464 --- /dev/null +++ b/testsuite/tests/simplStg/should_compile/T19717.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Foo where + + +f x = x `seq` [Just x, Just x] diff --git a/testsuite/tests/simplStg/should_compile/T19717.stderr b/testsuite/tests/simplStg/should_compile/T19717.stderr new file mode 100644 index 0000000000..9dd1e085f8 --- /dev/null +++ b/testsuite/tests/simplStg/should_compile/T19717.stderr @@ -0,0 +1,19 @@ + +==================== Final STG: ==================== +Foo.f :: forall {a}. a -> [GHC.Maybe.Maybe a] +[GblId, Arity=1, Str=<1L>, Cpr=2, Unf=OtherCon []] = + {} \r [x] + case x of x1 { + __DEFAULT -> + let { + sat [Occ=Once1] :: GHC.Maybe.Maybe a + [LclId] = + CCCS GHC.Maybe.Just! [x1]; } in + let { + sat [Occ=Once1] :: [GHC.Maybe.Maybe a] + [LclId] = + CCCS :! [sat GHC.Types.[]]; + } in : [sat sat]; + }; + + diff --git a/testsuite/tests/simplStg/should_compile/all.T b/testsuite/tests/simplStg/should_compile/all.T index bb2e25ed4b..8cc4c49922 100644 --- a/testsuite/tests/simplStg/should_compile/all.T +++ b/testsuite/tests/simplStg/should_compile/all.T @@ -10,3 +10,4 @@ def f( name, opts ): setTestOpts(f) test('T13588', [ grep_errmsg('case') ] , compile, ['-dverbose-stg2stg -fno-worker-wrapper']) +test('T19717', normal, compile, ['-ddump-stg-final -dsuppress-uniques -dno-typeable-binds']) diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index 564649b373..857c9f3659 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -395,8 +395,9 @@ test('T13098', normal, compile, ['-v0']) test('T11046', normal, multimod_compile, ['T11046','-v0']) test('T13366', [expect_broken_for(13366, ['ghci']), - # libstdc++ is named differently on FreeBSD - when(opsys('freebsd'), expect_broken(17739)), + # libstdc++ is GCC-specific on FreeBSD, the test will + # fail with clang, and pass with GCC. + when(opsys('freebsd'), fragile(17739)), when(opsys('darwin'), expect_broken(16083))], compile_and_run, ['-lstdc++ -v0']) diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs index f65deb456b..9f093c7faf 100644 --- a/utils/check-exact/ExactPrint.hs +++ b/utils/check-exact/ExactPrint.hs @@ -95,7 +95,6 @@ data PrintOptions m a = PrintOptions , epTokenPrint :: String -> m a , epWhitespacePrint :: String -> m a , epRigidity :: Rigidity - , epContext :: !AstContextSet } -- | Helper to create a 'PrintOptions' @@ -112,7 +111,6 @@ printOptions astPrint tokenPrint wsPrint rigidity = PrintOptions , epWhitespacePrint = wsPrint , epTokenPrint = tokenPrint , epRigidity = rigidity - , epContext = defaultACS } -- | Options which can be used to print as a normal String. @@ -153,7 +151,7 @@ data EPState = EPState -- --------------------------------------------------------------------- --- AZ:TODO: this can just be a function :: (EpAnn' a) -> Entry +-- AZ:TODO: this can just be a function :: (EpAnn a) -> Entry class HasEntry ast where fromAnn :: ast -> Entry @@ -172,11 +170,11 @@ markAnnotated a = enterAnn (getAnnotationEntry a) a data Entry = Entry Anchor EpAnnComments | NoEntryVal -instance (HasEntry (EpAnn' an)) => HasEntry (SrcSpanAnn' (EpAnn' an)) where - fromAnn (SrcSpanAnn EpAnnNotUsed ss) = Entry (spanAsAnchor ss) noCom +instance (HasEntry (EpAnn an)) => HasEntry (SrcSpanAnn' (EpAnn an)) where + fromAnn (SrcSpanAnn EpAnnNotUsed ss) = Entry (spanAsAnchor ss) emptyComments fromAnn (SrcSpanAnn an _) = fromAnn an -instance HasEntry (EpAnn' a) where +instance HasEntry (EpAnn a) where fromAnn (EpAnn anchor _ cs) = Entry anchor cs fromAnn EpAnnNotUsed = NoEntryVal @@ -242,7 +240,6 @@ enterAnn (Entry anchor' cs) a = do setExtraDP Nothing let edp = case med of Nothing -> edp'' - -- Just dp -> addDP dp edp'' Just (Anchor _ (MovedAnchor dp)) -> dp -- Replace original with desired one. Allows all -- list entry values to be DP (1,0) @@ -336,7 +333,7 @@ class (Typeable a) => ExactPrint a where -- | Bare Located elements are simply stripped off without further -- processing. instance (ExactPrint a) => ExactPrint (Located a) where - getAnnotationEntry (L l _) = Entry (spanAsAnchor l) noCom + getAnnotationEntry (L l _) = Entry (spanAsAnchor l) emptyComments exact (L _ a) = markAnnotated a instance (ExactPrint a) => ExactPrint (LocatedA a) where @@ -439,14 +436,14 @@ printStringAtSs ss str = printStringAtKw' (realSrcSpan ss) str -- --------------------------------------------------------------------- -- AZ:TODO get rid of this -printStringAtMkw :: Maybe EpaAnchor -> String -> EPP () +printStringAtMkw :: Maybe EpaLocation -> String -> EPP () printStringAtMkw (Just aa) s = printStringAtAA aa s -printStringAtMkw Nothing s = printStringAtLsDelta (DP 0 1) s +printStringAtMkw Nothing s = printStringAtLsDelta (SameLine 1) s -printStringAtAA :: EpaAnchor -> String -> EPP () -printStringAtAA (AR r) s = printStringAtKw' r s -printStringAtAA (AD d) s = do +printStringAtAA :: EpaLocation -> String -> EPP () +printStringAtAA (EpaSpan r) s = printStringAtKw' r s +printStringAtAA (EpaDelta d) s = do pe <- getPriorEndD p1 <- getPosP printStringAtLsDelta d s @@ -476,18 +473,18 @@ markExternalSourceText l (SourceText txt) _ = printStringAtKw' (realSrcSpan l) t markAddEpAnn :: AddEpAnn -> EPP () markAddEpAnn a@(AddEpAnn kw _) = mark [a] kw -markLocatedMAA :: EpAnn' a -> (a -> Maybe AddEpAnn) -> EPP () +markLocatedMAA :: EpAnn a -> (a -> Maybe AddEpAnn) -> EPP () markLocatedMAA EpAnnNotUsed _ = return () markLocatedMAA (EpAnn _ a _) f = case f a of Nothing -> return () Just aa -> markAddEpAnn aa -markLocatedAA :: EpAnn' a -> (a -> AddEpAnn) -> EPP () +markLocatedAA :: EpAnn a -> (a -> AddEpAnn) -> EPP () markLocatedAA EpAnnNotUsed _ = return () markLocatedAA (EpAnn _ a _) f = markKw (f a) -markLocatedAAL :: EpAnn' a -> (a -> [AddEpAnn]) -> AnnKeywordId -> EPP () +markLocatedAAL :: EpAnn a -> (a -> [AddEpAnn]) -> AnnKeywordId -> EPP () markLocatedAAL EpAnnNotUsed _ _ = return () markLocatedAAL (EpAnn _ a _) f kw = go (f a) where @@ -496,7 +493,7 @@ markLocatedAAL (EpAnn _ a _) f kw = go (f a) | kw' == kw = mark [aa] kw | otherwise = go as -markLocatedAALS :: EpAnn' a -> (a -> [AddEpAnn]) -> AnnKeywordId -> Maybe String -> EPP () +markLocatedAALS :: EpAnn a -> (a -> [AddEpAnn]) -> AnnKeywordId -> Maybe String -> EPP () markLocatedAALS an f kw Nothing = markLocatedAAL an f kw markLocatedAALS EpAnnNotUsed _ _ _ = return () markLocatedAALS (EpAnn _ a _) f kw (Just str) = go (f a) @@ -508,34 +505,34 @@ markLocatedAALS (EpAnn _ a _) f kw (Just str) = go (f a) -- --------------------------------------------------------------------- -markArrow :: EpAnn' TrailingAnn -> HsArrow GhcPs -> EPP () +markArrow :: EpAnn TrailingAnn -> HsArrow GhcPs -> EPP () markArrow EpAnnNotUsed _ = pure () markArrow an _mult = markKwT (anns an) -- --------------------------------------------------------------------- -markAnnCloseP :: EpAnn' AnnPragma -> EPP () +markAnnCloseP :: EpAnn AnnPragma -> EPP () markAnnCloseP an = markLocatedAALS an (pure . apr_close) AnnClose (Just "#-}") -markAnnOpenP :: EpAnn' AnnPragma -> SourceText -> String -> EPP () +markAnnOpenP :: EpAnn AnnPragma -> SourceText -> String -> EPP () markAnnOpenP an NoSourceText txt = markLocatedAALS an (pure . apr_open) AnnOpen (Just txt) markAnnOpenP an (SourceText txt) _ = markLocatedAALS an (pure . apr_open) AnnOpen (Just txt) -markAnnOpen :: EpAnn -> SourceText -> String -> EPP () +markAnnOpen :: EpAnn [AddEpAnn] -> SourceText -> String -> EPP () markAnnOpen an NoSourceText txt = markLocatedAALS an id AnnOpen (Just txt) markAnnOpen an (SourceText txt) _ = markLocatedAALS an id AnnOpen (Just txt) -markAnnOpen' :: Maybe EpaAnchor -> SourceText -> String -> EPP () +markAnnOpen' :: Maybe EpaLocation -> SourceText -> String -> EPP () markAnnOpen' ms NoSourceText txt = printStringAtMkw ms txt markAnnOpen' ms (SourceText txt) _ = printStringAtMkw ms txt -- --------------------------------------------------------------------- -markOpeningParen, markClosingParen :: EpAnn' AnnParen -> EPP () +markOpeningParen, markClosingParen :: EpAnn AnnParen -> EPP () markOpeningParen an = markParen an fst markClosingParen an = markParen an snd -markParen :: EpAnn' AnnParen -> (forall a. (a,a) -> a) -> EPP () +markParen :: EpAnn AnnParen -> (forall a. (a,a) -> a) -> EPP () markParen EpAnnNotUsed _ = return () markParen (EpAnn _ (AnnParen pt o c) _) f = markKwA (f $ kw pt) (f (o, c)) where @@ -544,34 +541,34 @@ markParen (EpAnn _ (AnnParen pt o c) _) f = markKwA (f $ kw pt) (f (o, c)) kw AnnParensSquare = (AnnOpenS, AnnCloseS) -markAnnKw :: EpAnn' a -> (a -> EpaAnchor) -> AnnKeywordId -> EPP () +markAnnKw :: EpAnn a -> (a -> EpaLocation) -> AnnKeywordId -> EPP () markAnnKw EpAnnNotUsed _ _ = return () markAnnKw (EpAnn _ a _) f kw = markKwA kw (f a) -markAnnKwAll :: EpAnn' a -> (a -> [EpaAnchor]) -> AnnKeywordId -> EPP () +markAnnKwAll :: EpAnn a -> (a -> [EpaLocation]) -> AnnKeywordId -> EPP () markAnnKwAll EpAnnNotUsed _ _ = return () markAnnKwAll (EpAnn _ a _) f kw = mapM_ (markKwA kw) (sort (f a)) -markAnnKwM :: EpAnn' a -> (a -> Maybe EpaAnchor) -> AnnKeywordId -> EPP () +markAnnKwM :: EpAnn a -> (a -> Maybe EpaLocation) -> AnnKeywordId -> EPP () markAnnKwM EpAnnNotUsed _ _ = return () markAnnKwM (EpAnn _ a _) f kw = go (f a) where go Nothing = return () go (Just s) = markKwA kw s -markALocatedA :: EpAnn' AnnListItem -> EPP () +markALocatedA :: EpAnn AnnListItem -> EPP () markALocatedA EpAnnNotUsed = return () markALocatedA (EpAnn _ a _) = markTrailing (lann_trailing a) -markEpAnn :: EpAnn -> AnnKeywordId -> EPP () +markEpAnn :: EpAnn [AddEpAnn] -> AnnKeywordId -> EPP () markEpAnn EpAnnNotUsed _ = return () markEpAnn (EpAnn _ a _) kw = mark a kw -markEpAnn' :: EpAnn' ann -> (ann -> [AddEpAnn]) -> AnnKeywordId -> EPP () +markEpAnn' :: EpAnn ann -> (ann -> [AddEpAnn]) -> AnnKeywordId -> EPP () markEpAnn' EpAnnNotUsed _ _ = return () markEpAnn' (EpAnn _ a _) f kw = mark (f a) kw -markEpAnnAll :: EpAnn' ann -> (ann -> [AddEpAnn]) -> AnnKeywordId -> EPP () +markEpAnnAll :: EpAnn ann -> (ann -> [AddEpAnn]) -> AnnKeywordId -> EPP () markEpAnnAll EpAnnNotUsed _ _ = return () markEpAnnAll (EpAnn _ a _) f kw = mapM_ markKw (sort anns) where @@ -598,12 +595,12 @@ markKw :: AddEpAnn -> EPP () markKw (AddEpAnn kw ss) = markKwA kw ss -- | This should be the main driver of the process, managing comments -markKwA :: AnnKeywordId -> EpaAnchor -> EPP () +markKwA :: AnnKeywordId -> EpaLocation -> EPP () markKwA kw aa = printStringAtAA aa (keywordToString (G kw)) -- --------------------------------------------------------------------- -markAnnList :: EpAnn' AnnList -> EPP () -> EPP () +markAnnList :: EpAnn AnnList -> EPP () -> EPP () markAnnList EpAnnNotUsed action = action markAnnList an@(EpAnn _ ann _) action = do p <- getPosP @@ -815,7 +812,7 @@ instance ExactPrint (InstDecl GhcPs) where -- --------------------------------------------------------------------- -exactDataFamInstDecl :: EpAnn -> TopLevelFlag -> (DataFamInstDecl GhcPs) -> EPP () +exactDataFamInstDecl :: EpAnn [AddEpAnn] -> TopLevelFlag -> (DataFamInstDecl GhcPs) -> EPP () exactDataFamInstDecl an top_lvl (DataFamInstDecl ( FamEqn { feqn_tycon = tycon , feqn_bndrs = bndrs @@ -1005,7 +1002,7 @@ instance ExactPrint (RuleDecl GhcPs) where -- inContext (Set.singleton Intercalate) $ mark GHC.AnnSemi -- markTrailingSemi -markActivation :: EpAnn' a -> (a -> [AddEpAnn]) -> Activation -> Annotated () +markActivation :: EpAnn a -> (a -> [AddEpAnn]) -> Activation -> Annotated () markActivation an fn act = do case act of ActiveBefore src phase -> do @@ -1109,7 +1106,7 @@ instance (ExactPrint body) => ExactPrint (FamEqn GhcPs body) where -- --------------------------------------------------------------------- exactHsFamInstLHS :: - EpAnn + EpAnn [AddEpAnn] -> LocatedN RdrName -- -> Maybe [LHsTyVarBndr () GhcPs] -> HsOuterTyVarBndrs () GhcPs @@ -1653,7 +1650,7 @@ instance ExactPrint (Sig GhcPs) where -- --------------------------------------------------------------------- -exactVarSig :: (ExactPrint a) => EpAnn' AnnSig -> [LocatedN RdrName] -> a -> EPP () +exactVarSig :: (ExactPrint a) => EpAnn AnnSig -> [LocatedN RdrName] -> a -> EPP () exactVarSig an vars ty = do mapM_ markAnnotated vars markLocatedAA an asDcolon @@ -2064,7 +2061,7 @@ instance ExactPrint (HsExpr GhcPs) where -- --------------------------------------------------------------------- exactDo :: (ExactPrint body) - => EpAnn' AnnList -> (HsStmtContext any) -> body -> EPP () + => EpAnn AnnList -> (HsStmtContext any) -> body -> EPP () exactDo an (DoExpr m) stmts = exactMdo an m AnnDo >> markAnnotatedWithLayout stmts exactDo an GhciStmtCtxt stmts = markLocatedAAL an al_rest AnnDo >> markAnnotatedWithLayout stmts exactDo an ArrowExpr stmts = markLocatedAAL an al_rest AnnDo >> markAnnotatedWithLayout stmts @@ -2073,7 +2070,7 @@ exactDo _ ListComp stmts = markAnnotatedWithLayout stmts exactDo _ MonadComp stmts = markAnnotatedWithLayout stmts exactDo _ _ _ = panic "pprDo" -- PatGuard, ParStmtCxt -exactMdo :: EpAnn' AnnList -> Maybe ModuleName -> AnnKeywordId -> EPP () +exactMdo :: EpAnn AnnList -> Maybe ModuleName -> AnnKeywordId -> EPP () exactMdo an Nothing kw = markLocatedAAL an al_rest kw exactMdo an (Just module_name) kw = markLocatedAALS an al_rest kw (Just n) where @@ -2582,7 +2579,7 @@ instance ExactPrint (ParStmtBlock GhcPs GhcPs) where getAnnotationEntry = const NoEntryVal exact (ParStmtBlock _ stmts _ _) = markAnnotated stmts -exactTransStmt :: EpAnn -> Maybe (LHsExpr GhcPs) -> (LHsExpr GhcPs) -> TransForm -> EPP () +exactTransStmt :: EpAnn [AddEpAnn] -> Maybe (LHsExpr GhcPs) -> (LHsExpr GhcPs) -> TransForm -> EPP () exactTransStmt an by using ThenForm = do debugM $ "exactTransStmt:ThenForm" markEpAnn an AnnThen @@ -2817,7 +2814,7 @@ instance ExactPrint (FamilyDecl GhcPs) where -- Just eqns -> vcat $ map (ppr_fam_inst_eqn . unLoc) eqns ) -- _ -> (empty, empty) -exactFlavour :: EpAnn -> FamilyInfo GhcPs -> EPP () +exactFlavour :: EpAnn [AddEpAnn] -> FamilyInfo GhcPs -> EPP () exactFlavour an DataFamily = markEpAnn an AnnData exactFlavour an OpenTypeFamily = markEpAnn an AnnType exactFlavour an (ClosedTypeFamily {}) = markEpAnn an AnnType @@ -2827,7 +2824,7 @@ exactFlavour an (ClosedTypeFamily {}) = markEpAnn an AnnType -- --------------------------------------------------------------------- -exactDataDefn :: EpAnn +exactDataDefn :: EpAnn [AddEpAnn] -> (Maybe (LHsContext GhcPs) -> EPP ()) -- Printing the header -> HsDataDefn GhcPs -> EPP () @@ -2852,7 +2849,7 @@ exactDataDefn an exactHdr mapM_ markAnnotated derivings return () -exactVanillaDeclHead :: EpAnn +exactVanillaDeclHead :: EpAnn [AddEpAnn] -> LocatedN RdrName -> LHsQTyVars GhcPs -> LexicalFixity @@ -3184,7 +3181,7 @@ instance ExactPrint (LocatedN RdrName) where markTrailing t markName :: NameAdornment - -> EpaAnchor -> Maybe (EpaAnchor,RdrName) -> EpaAnchor -> EPP () + -> EpaLocation -> Maybe (EpaLocation,RdrName) -> EpaLocation -> EPP () markName adorn open mname close = do let (kwo,kwc) = adornments adorn markKw (AddEpAnn kwo open) @@ -3208,7 +3205,7 @@ markTrailing ts = do -- --------------------------------------------------------------------- -- based on pp_condecls in Decls.hs -exact_condecls :: EpAnn -> [LConDecl GhcPs] -> EPP () +exact_condecls :: EpAnn [AddEpAnn] -> [LConDecl GhcPs] -> EPP () exact_condecls an cs | gadt_syntax -- In GADT syntax -- = hang (text "where") 2 (vcat (map ppr cs)) @@ -3828,7 +3825,7 @@ sourceTextToString (SourceText txt) _ = txt -- --------------------------------------------------------------------- -exactUserCon :: (ExactPrint con) => EpAnn -> con -> HsConPatDetails GhcPs -> EPP () +exactUserCon :: (ExactPrint con) => EpAnn [AddEpAnn] -> con -> HsConPatDetails GhcPs -> EPP () exactUserCon _ c (InfixCon p1 p2) = markAnnotated p1 >> markAnnotated c >> markAnnotated p2 exactUserCon an c details = do markAnnotated c @@ -3868,7 +3865,7 @@ printStringAtLsDelta cl s = do -- --------------------------------------------------------------------- isGoodDeltaWithOffset :: DeltaPos -> LayoutStartCol -> Bool -isGoodDeltaWithOffset dp colOffset = isGoodDelta (DP l c) +isGoodDeltaWithOffset dp colOffset = isGoodDelta (deltaPos l c) where (l,c) = undelta (0,0) dp colOffset printQueuedComment :: (Monad m, Monoid w) => RealSrcSpan -> Comment -> DeltaPos -> EP w m () @@ -3877,7 +3874,7 @@ printQueuedComment loc Comment{commentContents} dp = do colOffset <- getLayoutOffsetP let (dr,dc) = undelta (0,0) dp colOffset -- do not lose comments against the left margin - when (isGoodDelta (DP dr (max 0 dc))) $ do + when (isGoodDelta (deltaPos dr (max 0 dc))) $ do printCommentAt (undelta p dp colOffset) commentContents setPriorEndASTD False loc p' <- getPosP @@ -3911,7 +3908,7 @@ printQueuedComment Comment{commentContents} dp = do -- withOffset :: (Monad m, Monoid w) => Annotation -> (EP w m a -> EP w m a) withOffset a = - local (\s -> s { epAnn = a, epContext = pushAcs (epContext s) }) + local (\s -> s { epAnn = a }) ------------------------------------------------------------------------ @@ -4083,7 +4080,8 @@ printString layout str = do modify (\s -> s { pLHS = LayoutStartCol c, pMarkLayout = False } ) -- Advance position, taking care of any newlines in the string - let strDP@(DP cr _cc) = dpFromString str + let strDP = dpFromString str + cr = getDeltaLine strDP p <- getPosP colOffset <- getLayoutOffsetP debugM $ "printString:(p,colOffset,strDP,cr)=" ++ show (p,colOffset,strDP,cr) diff --git a/utils/check-exact/Lookup.hs b/utils/check-exact/Lookup.hs index 8edf4ac1f0..18e4e32f6f 100644 --- a/utils/check-exact/Lookup.hs +++ b/utils/check-exact/Lookup.hs @@ -5,12 +5,7 @@ module Lookup , Comment(..) ) where --- import Language.Haskell.ExactPrint.Types import GHC (AnnKeywordId(..)) --- import GHC.Utils.Outputable hiding ( (<>) ) --- import Data.Data (Data) --- import GHC.Types.SrcLoc --- import GHC.Driver.Session import Types -- | Maps `AnnKeywordId` to the corresponding String representation. @@ -78,7 +73,6 @@ keywordToString kw = (G AnnLam ) -> "\\" (G AnnLarrow ) -> "<-" (G AnnLet ) -> "let" - -- (G AnnLolly ) -> "#->" (G AnnLollyU ) -> "⊸" (G AnnMdo ) -> "mdo" (G AnnMinus ) -> "-" @@ -93,8 +87,6 @@ keywordToString kw = (G AnnOpenEQU ) -> "⟦" (G AnnOpenP ) -> "(" (G AnnOpenPH ) -> "(#" - -- (G AnnOpenPE ) -> "$(" - -- (G AnnOpenPTE ) -> "$$(" (G AnnOpenS ) -> "[" (G AnnPattern ) -> "pattern" (G AnnPercent ) -> "%" diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs index 0b5594fe20..a9618be40b 100644 --- a/utils/check-exact/Main.hs +++ b/utils/check-exact/Main.hs @@ -51,7 +51,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/exactprin -- "../../testsuite/tests/ghc-api/exactprint/LocToName.hs" (Just changeLocToName) -- "../../testsuite/tests/ghc-api/exactprint/LetIn1.hs" (Just changeLetIn1) -- "../../testsuite/tests/ghc-api/exactprint/WhereIn4.hs" (Just changeWhereIn4) - -- "../../testsuite/tests/ghc-api/exactprint/AddDecl1.hs" (Just changeAddDecl1) + "../../testsuite/tests/ghc-api/exactprint/AddDecl1.hs" (Just changeAddDecl1) -- "../../testsuite/tests/ghc-api/exactprint/AddDecl2.hs" (Just changeAddDecl2) -- "../../testsuite/tests/ghc-api/exactprint/AddDecl3.hs" (Just changeAddDecl3) -- "../../testsuite/tests/ghc-api/exactprint/LocalDecls.hs" (Just changeLocalDecls) @@ -63,7 +63,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/exactprin -- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl3.hs" (Just addLocaLDecl3) -- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl4.hs" (Just addLocaLDecl4) -- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl5.hs" (Just addLocaLDecl5) - -- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl6.hs" (Just (Just addLocaLDecl6)) + -- "../../testsuite/tests/ghc-api/exactprint/AddLocalDecl6.hs" (Just addLocaLDecl6) -- "../../testsuite/tests/ghc-api/exactprint/RmDecl1.hs" (Just rmDecl1) -- "../../testsuite/tests/ghc-api/exactprint/RmDecl2.hs" (Just rmDecl2) -- "../../testsuite/tests/ghc-api/exactprint/RmDecl3.hs" (Just rmDecl3) @@ -75,8 +75,8 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/exactprin -- "../../testsuite/tests/ghc-api/exactprint/RmTypeSig2.hs" (Just rmTypeSig2) -- "../../testsuite/tests/ghc-api/exactprint/AddHiding1.hs" (Just addHiding1) -- "../../testsuite/tests/ghc-api/exactprint/AddHiding2.hs" (Just addHiding2) - -- "../../testsuite/tests/printer/Ppr001.hs" Nothing + -- "../../testsuite/tests/printer/Ppr001.hs" Nothing -- "../../testsuite/tests/ghc-api/annotations/CommentsTest.hs" Nothing -- "../../testsuite/tests/hiefile/should_compile/Constructors.hs" Nothing -- "../../testsuite/tests/hiefile/should_compile/Scopes.hs" Nothing @@ -172,7 +172,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/exactprin -- "../../testsuite/tests/printer/Test16230.hs" Nothing -- "../../testsuite/tests/printer/Test16236.hs" Nothing -- "../../testsuite/tests/printer/Test17519.hs" Nothing - "../../testsuite/tests/printer/InTreeAnnotations1.hs" Nothing + -- "../../testsuite/tests/printer/InTreeAnnotations1.hs" Nothing -- "../../testsuite/tests/qualifieddo/should_compile/qdocompile001.hs" Nothing -- "../../testsuite/tests/typecheck/should_fail/StrictBinds.hs" Nothing @@ -432,9 +432,9 @@ changeLetIn1 _libdir parsed [l2,_l1] = map wrapDecl $ bagToList bagDecls bagDecls' = listToBag $ concatMap decl2Bind [l2] (L (SrcSpanAnn _ le) e) = expr - a = (SrcSpanAnn (EpAnn (Anchor (realSrcSpan le) (MovedAnchor (DP 0 1))) mempty noCom) le) + a = (SrcSpanAnn (EpAnn (Anchor (realSrcSpan le) (MovedAnchor (SameLine 1))) mempty emptyComments) le) expr' = L a e - in (HsLet (EpAnn anc (AnnsLet l (AD (DP 1 0))) cs) + in (HsLet (EpAnn anc (AnnsLet l (EpaDelta (DifferentLine 1 0))) cs) (HsValBinds x (ValBinds xv bagDecls' sigs)) expr') replace x = x @@ -445,7 +445,7 @@ changeLetIn1 _libdir parsed changeAddDecl1 :: Changer changeAddDecl1 libdir top = do Right decl <- withDynFlags libdir (\df -> parseDecl df "<interactive>" "nn = n2") - let decl' = setEntryDP' decl (DP 2 0) + let decl' = setEntryDP' decl (DifferentLine 2 0) let (p',(_,_),_) = runTransform mempty doAddDecl doAddDecl = everywhereM (mkM replaceTopLevelDecls) top @@ -457,7 +457,7 @@ changeAddDecl1 libdir top = do changeAddDecl2 :: Changer changeAddDecl2 libdir top = do Right decl <- withDynFlags libdir (\df -> parseDecl df "<interactive>" "nn = n2") - let decl' = setEntryDP' decl (DP 2 0) + let decl' = setEntryDP' decl (DifferentLine 2 0) let top' = anchorEof top let (p',(_,_),_) = runTransform mempty doAddDecl @@ -471,13 +471,13 @@ changeAddDecl2 libdir top = do changeAddDecl3 :: Changer changeAddDecl3 libdir top = do Right decl <- withDynFlags libdir (\df -> parseDecl df "<interactive>" "nn = n2") - let decl' = setEntryDP' decl (DP 2 0) + let decl' = setEntryDP' decl (DifferentLine 2 0) let (p',(_,_),_) = runTransform mempty doAddDecl doAddDecl = everywhereM (mkM replaceTopLevelDecls) top f d (l1:l2:ls) = l1:d:l2':ls where - l2' = setEntryDP' l2 (DP 2 0) + l2' = setEntryDP' l2 (DifferentLine 2 0) replaceTopLevelDecls :: ParsedSource -> Transform ParsedSource replaceTopLevelDecls m = insertAt f m decl' return p' @@ -489,8 +489,8 @@ changeLocalDecls :: Changer changeLocalDecls libdir (L l p) = do Right s@(L ls (SigD _ sig)) <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int") Right d@(L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") - let decl' = setEntryDP' (L ld decl) (DP 1 0) - let sig' = setEntryDP' (L ls sig) (DP 0 0) + let decl' = setEntryDP' (L ld decl) (DifferentLine 1 0) + let sig' = setEntryDP' (L ls sig) (SameLine 0) let (p',(_,_),_w) = runTransform mempty doAddLocal doAddLocal = everywhereM (mkM replaceLocalBinds) p replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs) @@ -501,10 +501,10 @@ changeLocalDecls libdir (L l p) = do let oldDecls' = captureLineSpacing oldDecls let oldBinds = concatMap decl2Bind oldDecls' (os:oldSigs) = concatMap decl2Sig oldDecls' - os' = setEntryDP' os (DP 2 0) + os' = setEntryDP' os (DifferentLine 2 0) let sortKey = captureOrder decls let (EpAnn anc (AnnList (Just (Anchor anc2 _)) a b c dd) cs) = van - let van' = (EpAnn anc (AnnList (Just (Anchor anc2 (MovedAnchor (DP 1 4)))) a b c dd) cs) + let van' = (EpAnn anc (AnnList (Just (Anchor anc2 (MovedAnchor (DifferentLine 1 4)))) a b c dd) cs) let binds' = (HsValBinds van' (ValBinds sortKey (listToBag $ decl':oldBinds) (sig':os':oldSigs))) @@ -520,20 +520,20 @@ changeLocalDecls2 :: Changer changeLocalDecls2 libdir (L l p) = do Right d@(L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") Right s@(L ls (SigD _ sig)) <- withDynFlags libdir (\df -> parseDecl df "sig" "nn :: Int") - let decl' = setEntryDP' (L ld decl) (DP 1 0) - let sig' = setEntryDP' (L ls sig) (DP 0 2) + let decl' = setEntryDP' (L ld decl) (DifferentLine 1 0) + let sig' = setEntryDP' (L ls sig) (SameLine 2) let (p',(_,_),_w) = runTransform mempty doAddLocal doAddLocal = everywhereM (mkM replaceLocalBinds) p replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs) -> Transform (LMatch GhcPs (LHsExpr GhcPs)) replaceLocalBinds (L lm (Match ma mln pats (GRHSs _ rhs EmptyLocalBinds{}))) = do newSpan <- uniqueSrcSpanT - let anc = (Anchor (rs newSpan) (MovedAnchor (DP 1 2))) - let anc2 = (Anchor (rs newSpan) (MovedAnchor (DP 1 4))) + let anc = (Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 2))) + let anc2 = (Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 4))) let an = EpAnn anc (AnnList (Just anc2) Nothing Nothing - [(undeltaSpan (rs newSpan) AnnWhere (DP 0 0))] []) - noCom + [(undeltaSpan (rs newSpan) AnnWhere (SameLine 0))] []) + emptyComments let decls = [s,d] let sortKey = captureOrder decls let binds = (HsValBinds an (ValBinds sortKey (listToBag $ [decl']) @@ -562,9 +562,9 @@ changeWhereIn3b _libdir (L l p) = do let decls0 = hsmodDecls p (decls,(_,_),w) = runTransform mempty (balanceCommentsList decls0) (de0:_:de1:d2:_) = decls - de0' = setEntryDP' de0 (DP 2 0) - de1' = setEntryDP' de1 (DP 2 0) - d2' = setEntryDP' d2 (DP 2 0) + de0' = setEntryDP' de0 (DifferentLine 2 0) + de1' = setEntryDP' de1 (DifferentLine 2 0) + d2' = setEntryDP' d2 (DifferentLine 2 0) decls' = d2':de1':de0':(tail decls) debugM $ unlines w debugM $ "changeWhereIn3b:de1':" ++ showAst de1' @@ -576,7 +576,7 @@ changeWhereIn3b _libdir (L l p) = do addLocaLDecl1 :: Changer addLocaLDecl1 libdir lp = do Right (L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") - let decl' = setEntryDP' (L ld decl) (DP 1 4) + let decl' = setEntryDP' (L ld decl) (DifferentLine 1 4) doAddLocal = do (de1:d2:d3:_) <- hsDecls lp (de1'',d2') <- balanceComments de1 d2 @@ -600,7 +600,7 @@ addLocaLDecl2 libdir lp = do (parent',_) <- modifyValD (getLocA de1) de1'' $ \_m (d:ds) -> do newDecl' <- transferEntryDP' d newDecl - let d' = setEntryDP' d (DP 1 0) + let d' = setEntryDP' d (DifferentLine 1 0) return ((newDecl':d':ds),Nothing) replaceDecls lp [parent',d2'] @@ -620,7 +620,7 @@ addLocaLDecl3 libdir lp = do (de1'',d2') <- balanceComments de1 d2 (parent',_) <- modifyValD (getLocA de1) de1'' $ \_m (d:ds) -> do - let newDecl' = setEntryDP' newDecl (DP 1 0) + let newDecl' = setEntryDP' newDecl (DifferentLine 1 0) return (((d:ds) ++ [newDecl']),Nothing) replaceDecls (anchorEof lp) [parent',d2'] @@ -639,8 +639,8 @@ addLocaLDecl4 libdir lp = do doAddLocal = do (parent:ds) <- hsDecls lp - let newDecl' = setEntryDP' newDecl (DP 1 0) - let newSig' = setEntryDP' newSig (DP 1 4) + let newDecl' = setEntryDP' newDecl (DifferentLine 1 0) + let newSig' = setEntryDP' newSig (DifferentLine 1 4) (parent',_) <- modifyValD (getLocA parent) parent $ \_m decls -> do return ((decls++[newSig',newDecl']),Nothing) @@ -661,10 +661,10 @@ addLocaLDecl5 _libdir lp = do decls <- hsDecls lp [s1,de1,d2,d3] <- balanceCommentsList decls - let d3' = setEntryDP' d3 (DP 2 0) + let d3' = setEntryDP' d3 (DifferentLine 2 0) (de1',_) <- modifyValD (getLocA de1) de1 $ \_m _decls -> do - let d2' = setEntryDP' d2 (DP 1 0) + let d2' = setEntryDP' d2 (DifferentLine 1 0) return ([d2'],Nothing) replaceDecls lp [s1,de1',d3'] @@ -678,7 +678,7 @@ addLocaLDecl6 :: Changer addLocaLDecl6 libdir lp = do Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "x = 3") let - newDecl' = setEntryDP' newDecl (DP 1 4) + newDecl' = setEntryDP' newDecl (DifferentLine 1 4) doAddLocal = do decls0 <- hsDecls lp [de1'',d2] <- balanceCommentsList decls0 @@ -740,7 +740,7 @@ rmDecl3 _libdir lp = do [de1,d2] <- hsDecls lp (de1',Just sd1) <- modifyValD (getLocA de1) de1 $ \_m [sd1] -> do - let sd1' = setEntryDP' sd1 (DP 2 0) + let sd1' = setEntryDP' sd1 (DifferentLine 2 0) return ([],Just sd1') replaceDecls lp [de1',sd1,d2] @@ -760,7 +760,7 @@ rmDecl4 _libdir lp = do (de1',Just sd1) <- modifyValD (getLocA de1) de1 $ \_m [sd1,sd2] -> do sd2' <- transferEntryDP' sd1 sd2 - let sd1' = setEntryDP' sd1 (DP 2 0) + let sd1' = setEntryDP' sd1 (DifferentLine 2 0) return ([sd2'],Just sd1') replaceDecls (anchorEof lp) [de1',sd1] @@ -882,7 +882,7 @@ addHiding1 _libdir (L l p) = do (Just (AddEpAnn AnnCloseP d0)) [(AddEpAnn AnnHiding d1)] []) - noCom) l0) [v1,v2] + emptyComments) l0) [v1,v2] imp1' = imp1 { ideclHiding = Just (True,impHiding)} p' = p { hsmodImports = [L li imp1',imp2]} return (L l p') @@ -907,7 +907,7 @@ addHiding2 _libdir (L l p) = do (Just (AddEpAnn AnnCloseP d0)) [(AddEpAnn AnnHiding d1)] []) - noCom) (locA lh)) + emptyComments) (locA lh)) n1 = L (noAnnSrcSpanDP0 l1) (mkVarUnqual (mkFastString "n1")) n2 = L (noAnnSrcSpanDP0 l2) (mkVarUnqual (mkFastString "n2")) v1 = L (addComma $ noAnnSrcSpanDP0 l1) (IEVar noExtField (L (noAnnSrcSpanDP0 l1) (IEName n1))) diff --git a/utils/check-exact/Parsers.hs b/utils/check-exact/Parsers.hs index f1437869ee..03616f846a 100644 --- a/utils/check-exact/Parsers.hs +++ b/utils/check-exact/Parsers.hs @@ -44,16 +44,10 @@ module Parsers ( , postParseTransform ) where --- import Language.Haskell.GHC.ExactPrint.Annotate --- import Language.Haskell.GHC.ExactPrint.Delta import Preprocess import Types import Control.Monad.RWS --- import Data.Data (Data) - - --- import GHC.Paths (libdir) import qualified GHC hiding (parseModule) import qualified Control.Monad.IO.Class as GHC @@ -71,8 +65,6 @@ import qualified GHC.Utils.Error as GHC import qualified GHC.LanguageExtensions as LangExt --- import qualified Data.Map as Map - {-# ANN module "HLint: ignore Eta reduce" #-} {-# ANN module "HLint: ignore Redundant do" #-} {-# ANN module "HLint: ignore Reduce duplication" #-} @@ -98,8 +90,6 @@ parseWithECP :: (GHC.DisambECP w) -> String -> ParseResult (GHC.LocatedA w) parseWithECP dflags fileName parser s = - -- case runParser ff dflags fileName s of - -- case runParser (parser >>= \p -> GHC.runECP_P p) dflags fileName s of case runParser (parser >>= \p -> GHC.runPV $ GHC.unECP p) dflags fileName s of GHC.PFailed pst -> Left (fmap GHC.mkParserErr $ GHC.getErrorMessages pst) GHC.POk _ pmod -> Right pmod @@ -275,7 +265,6 @@ postParseTransform postParseTransform parseRes = fmap mkAnns parseRes where mkAnns (_cs, _, m) = m - -- (relativiseEpAnnsWithOptions opts cs m apianns, m) -- | Internal function. Initializes DynFlags value for parsing. -- diff --git a/utils/check-exact/Preprocess.hs b/utils/check-exact/Preprocess.hs index 904e76938e..58cb6d028c 100644 --- a/utils/check-exact/Preprocess.hs +++ b/utils/check-exact/Preprocess.hs @@ -213,7 +213,6 @@ getPreprocessedSrcDirectPrim cppOptions src_fn = do hsc_env <- GHC.getSession let dfs = GHC.hsc_dflags hsc_env new_env = hsc_env { GHC.hsc_dflags = injectCppOptions cppOptions dfs } - -- (dflags', hspp_fn) <- r <- GHC.liftIO $ GHC.preprocess new_env src_fn Nothing (Just (GHC.Cpp GHC.HsSrcFile)) case r of Left err -> error $ showErrorMessages err @@ -309,4 +308,3 @@ mergeBy cmp (allx@(x:xs)) (ally@(y:ys)) -- Someone please put this code out of its misery. | (x `cmp` y) <= EQ = x : mergeBy cmp xs ally | otherwise = y : mergeBy cmp allx ys - diff --git a/utils/check-exact/Transform.hs b/utils/check-exact/Transform.hs index 7d68da858a..044af3c784 100644 --- a/utils/check-exact/Transform.hs +++ b/utils/check-exact/Transform.hs @@ -118,8 +118,6 @@ import GHC hiding (parseModule, parsedSource) import GHC.Data.Bag import GHC.Data.FastString --- import qualified Data.Generics as SYB - import Data.Data import Data.List (sort, sortBy, find) import Data.Maybe @@ -130,7 +128,6 @@ import Data.Functor.Identity import Control.Monad.State import Control.Monad.Writer --- import Debug.Trace ------------------------------------------------------------------------------ -- Transformation of source elements @@ -274,14 +271,14 @@ captureMatchLineSpacing (L l (ValD x (FunBind a b (MG c (L d ms ) e) f))) captureMatchLineSpacing d = d captureLineSpacing :: Monoid t - => [LocatedAn t e] -> [GenLocated (SrcSpanAnn' (EpAnn' t)) e] + => [LocatedAn t e] -> [GenLocated (SrcSpanAnn' (EpAnn t)) e] captureLineSpacing [] = [] captureLineSpacing [d] = [d] captureLineSpacing (de1:d2:ds) = de1:captureLineSpacing (d2':ds) where (l1,_) = ss2pos $ rs $ getLocA de1 (l2,_) = ss2pos $ rs $ getLocA d2 - d2' = setEntryDP' d2 (DP (l2-l1) 0) + d2' = setEntryDP' d2 (deltaPos (l2-l1) 0) -- --------------------------------------------------------------------- @@ -297,8 +294,8 @@ captureTypeSigSpacing (L l (SigD x (TypeSig (EpAnn anc (AnnSig dc rs') cs) ns (H L (SrcSpanAnn (EpAnn anc' _ _) _) _ -> anchor anc' -- TODO MovedAnchor? -- DP (line, col) = ss2delta (ss2pos $ anchor $ getLoc lc) r dc' = case dca of - AR r -> AddEpAnn kw (AD $ ss2delta (ss2posEnd rd) r) - AD _ -> AddEpAnn kw dca + EpaSpan r -> AddEpAnn kw (EpaDelta $ ss2delta (ss2posEnd rd) r) + EpaDelta _ -> AddEpAnn kw dca -- --------------------------------- @@ -307,16 +304,16 @@ captureTypeSigSpacing (L l (SigD x (TypeSig (EpAnn anc (AnnSig dc rs') cs) ns (H (L (SrcSpanAnn EpAnnNotUsed ll) b) -> let op = case dca of - AR r -> MovedAnchor (ss2delta (ss2posEnd r) (realSrcSpan ll)) - AD _ -> MovedAnchor (DP 0 1) - in (L (SrcSpanAnn (EpAnn (Anchor (realSrcSpan ll) op) mempty noCom) ll) b) + EpaSpan r -> MovedAnchor (ss2delta (ss2posEnd r) (realSrcSpan ll)) + EpaDelta _ -> MovedAnchor (SameLine 1) + in (L (SrcSpanAnn (EpAnn (Anchor (realSrcSpan ll) op) mempty emptyComments) ll) b) (L (SrcSpanAnn (EpAnn (Anchor r op) a c) ll) b) -> let op' = case op of MovedAnchor _ -> op _ -> case dca of - AR dcr -> MovedAnchor (ss2delta (ss2posEnd dcr) r) - AD _ -> MovedAnchor (DP 0 1) + EpaSpan dcr -> MovedAnchor (ss2delta (ss2posEnd dcr) r) + EpaDelta _ -> MovedAnchor (SameLine 1) in (L (SrcSpanAnn (EpAnn (Anchor r op') a c) ll) b) captureTypeSigSpacing s = s @@ -366,7 +363,7 @@ addSimpleAnnT ast dp kds = do -- |Add a trailing comma annotation, unless there is already one addTrailingCommaT :: (Data a,Monad m) => Located a -> TransformT m () addTrailingCommaT ast = do - modifyAnnsT (addTrailingComma ast (DP 0 0)) + modifyAnnsT (addTrailingComma ast (SameLine 0)) -- --------------------------------------------------------------------- @@ -435,7 +432,7 @@ setPrecedingLinesDecl ld n c ans = setPrecedingLines ld n c ans -- | Adjust the entry annotations to provide an `n` line preceding gap setPrecedingLines :: (Data a) => LocatedA a -> Int -> Int -> Anns -> Anns -setPrecedingLines ast n c anne = setEntryDP ast (DP n c) anne +setPrecedingLines ast n c anne = setEntryDP ast (deltaPos n c) anne -- --------------------------------------------------------------------- @@ -444,7 +441,7 @@ setPrecedingLines ast n c anne = setEntryDP ast (DP n c) anne getEntryDP :: (Data a) => Anns -> Located a -> DeltaPos getEntryDP anns ast = case Map.lookup (mkAnnKey ast) anns of - Nothing -> DP 0 0 + Nothing -> SameLine 0 Just ann -> annTrueEntryDelta ann -- --------------------------------------------------------------------- @@ -468,7 +465,7 @@ setEntryDPDecl d dp = setEntryDP' d dp setEntryDP' :: (Monoid t) => LocatedAn t a -> DeltaPos -> LocatedAn t a setEntryDP' (L (SrcSpanAnn EpAnnNotUsed l) a) dp = L (SrcSpanAnn - (EpAnn (Anchor (realSrcSpan l) (MovedAnchor dp)) mempty noCom) + (EpAnn (Anchor (realSrcSpan l) (MovedAnchor dp)) mempty emptyComments) l) a setEntryDP' (L (SrcSpanAnn (EpAnn (Anchor r _) an (EpaComments [])) l) a) dp = L (SrcSpanAnn @@ -487,13 +484,13 @@ setEntryDP' (L (SrcSpanAnn (EpAnn (Anchor r _) an cs) l) a) dp where cs'' = setPriorComments cs (L (Anchor (anchor ca) (MovedAnchor dp)) c:cs') lc = head $ reverse $ (L ca c:cs') - DP line col = ss2delta (ss2pos $ anchor $ getLoc lc) r + delta = ss2delta (ss2pos $ anchor $ getLoc lc) r + line = getDeltaLine delta + col = deltaColumn delta -- TODO: this adjustment by 1 happens all over the place. Generalise it - edp' = if line == 0 then DP line col - else DP line (col - 1) + edp' = if line == 0 then SameLine col + else DifferentLine line (col - 1) edp = edp' `debug` ("setEntryDP' :" ++ showGhc (edp', (ss2pos $ anchor $ getLoc lc), r)) - -- edp = if line == 0 then DP (line, col) - -- else DP (line, col - 1) -- |Set the true entry 'DeltaPos' from the annotation for a given AST -- element. This is the 'DeltaPos' ignoring any comments. @@ -502,15 +499,15 @@ setEntryDP _ast _dp anns = anns -- --------------------------------------------------------------------- -addEpaAnchorDelta :: LayoutStartCol -> RealSrcSpan -> EpaAnchor -> EpaAnchor -addEpaAnchorDelta _off _anc (AD d) = AD d -addEpaAnchorDelta off anc (AR r) - = AD (adjustDeltaForOffset 0 off (ss2deltaEnd anc r)) +addEpaLocationDelta :: LayoutStartCol -> RealSrcSpan -> EpaLocation -> EpaLocation +addEpaLocationDelta _off _anc (EpaDelta d) = EpaDelta d +addEpaLocationDelta off anc (EpaSpan r) + = EpaDelta (adjustDeltaForOffset 0 off (ss2deltaEnd anc r)) -- Set the entry DP for an element coming after an existing keyword annotation -setEntryDPFromAnchor :: LayoutStartCol -> EpaAnchor -> LocatedA t -> LocatedA t -setEntryDPFromAnchor _off (AD _) (L la a) = L la a -setEntryDPFromAnchor off (AR anc) ll@(L la _) = setEntryDP' ll dp' +setEntryDPFromAnchor :: LayoutStartCol -> EpaLocation -> LocatedA t -> LocatedA t +setEntryDPFromAnchor _off (EpaDelta _) (L la a) = L la a +setEntryDPFromAnchor off (EpaSpan anc) ll@(L la _) = setEntryDP' ll dp' where r = case la of (SrcSpanAnn EpAnnNotUsed l) -> realSrcSpan l @@ -551,7 +548,7 @@ transferEntryDP (L (SrcSpanAnn EpAnnNotUsed _l1) _) (L (SrcSpanAnn (EpAnn anc2 a transferEntryDP' :: (Monad m) => LHsDecl GhcPs -> LHsDecl GhcPs -> TransformT m (LHsDecl GhcPs) transferEntryDP' la lb = do (L l2 b) <- transferEntryDP la lb - return (L l2 (pushDeclDP b (DP 0 0))) + return (L l2 (pushDeclDP b (SameLine 0))) -- There is an off-by-one in DPs. I *think* it has to do wether we -- calculate the final position when applying it against the stored @@ -559,8 +556,8 @@ transferEntryDP' la lb = do -- of it and come up with a canonical DP. This function adjusts a -- "comment space" DP to a "enterAnn" space one kludgeAnchor :: Anchor -> Anchor -kludgeAnchor a@(Anchor _ (MovedAnchor (DP 0 _))) = a -kludgeAnchor (Anchor a (MovedAnchor (DP r c))) = (Anchor a (MovedAnchor (DP r (c - 1)))) +kludgeAnchor a@(Anchor _ (MovedAnchor (SameLine _))) = a +kludgeAnchor (Anchor a (MovedAnchor (DifferentLine r c))) = (Anchor a (MovedAnchor (deltaPos r (c - 1)))) kludgeAnchor a = a pushDeclDP :: HsDecl GhcPs -> DeltaPos -> HsDecl GhcPs @@ -665,7 +662,6 @@ balanceCommentsMatch (L l (Match am mctxt pats (GRHSs xg grhss binds))) = do (SrcSpanAnn an1 _loc1) = l anc1 = addCommentOrigDeltas $ epAnnComments an1 cs1f = getFollowingComments anc1 - -- (move',stay') = break simpleBreak (commentsDeltas (anchorFromLocatedA (L l ())) cs1f) (move',stay') = break simpleBreak (trailingCommentsDeltas (anchorFromLocatedA (L l ())) cs1f) move = map snd move' stay = map snd stay' @@ -817,8 +813,8 @@ commentOrigDeltas lcs@(L _ (GHC.EpaComment _ pt):_) = go pt lcs op' = if r == 0 then MovedAnchor (ss2delta (r,c+1) la) else MovedAnchor (ss2delta (r,c) la) - op = if t == EpaEofComment && op' == MovedAnchor (DP 0 0) - then MovedAnchor (DP 1 0) + op = if t == EpaEofComment && op' == MovedAnchor (SameLine 0) + then MovedAnchor (DifferentLine 1 0) else op' addCommentOrigDeltas :: EpAnnComments -> EpAnnComments @@ -826,7 +822,7 @@ addCommentOrigDeltas (EpaComments cs) = EpaComments (commentOrigDeltas cs) addCommentOrigDeltas (EpaCommentsBalanced pcs fcs) = EpaCommentsBalanced (commentOrigDeltas pcs) (commentOrigDeltas fcs) -addCommentOrigDeltasAnn :: (EpAnn' a) -> (EpAnn' a) +addCommentOrigDeltasAnn :: (EpAnn a) -> (EpAnn a) addCommentOrigDeltasAnn EpAnnNotUsed = EpAnnNotUsed addCommentOrigDeltasAnn (EpAnn e a cs) = EpAnn e a (addCommentOrigDeltas cs) @@ -855,7 +851,7 @@ balanceSameLineComments (L la (Match anm mctxt pats (GRHSs x grhss lb))) = do where (SrcSpanAnn an1 _loc1) = la anc1 = addCommentOrigDeltas $ epAnnComments an1 - (EpAnn anc an _) = ga :: EpAnn' GrhsAnn + (EpAnn anc an _) = ga :: EpAnn GrhsAnn (csp,csf) = case anc1 of EpaComments cs -> ([],cs) EpaCommentsBalanced p f -> (p,f) @@ -894,7 +890,8 @@ balanceTrailingComments first second = do an1' = an1 { annFollowingComments = stay } ans' = Map.insert k1 an1' $ Map.insert k2 an2 ans - simpleBreak (_,DP r _c) = r > 0 + simpleBreak (_,SameLine _) = False + simpleBreak (_,DifferentLine _ _) = True ans <- getAnnsT let (ans',mov) = moveComments simpleBreak ans @@ -944,40 +941,40 @@ deltaAnchor (Anchor anc _) ss = Anchor anc (MovedAnchor dp) -- | Create a @SrcSpanAnn@ with a @MovedAnchor@ operation using the -- given @DeltaPos@. -noAnnSrcSpanDP :: (Monoid ann) => SrcSpan -> DeltaPos -> SrcSpanAnn' (EpAnn' ann) +noAnnSrcSpanDP :: (Monoid ann) => SrcSpan -> DeltaPos -> SrcSpanAnn' (EpAnn ann) noAnnSrcSpanDP l dp - = SrcSpanAnn (EpAnn (Anchor (realSrcSpan l) (MovedAnchor dp)) mempty noCom) l + = SrcSpanAnn (EpAnn (Anchor (realSrcSpan l) (MovedAnchor dp)) mempty emptyComments) l -noAnnSrcSpanDP0 :: (Monoid ann) => SrcSpan -> SrcSpanAnn' (EpAnn' ann) -noAnnSrcSpanDP0 l = noAnnSrcSpanDP l (DP 0 0) +noAnnSrcSpanDP0 :: (Monoid ann) => SrcSpan -> SrcSpanAnn' (EpAnn ann) +noAnnSrcSpanDP0 l = noAnnSrcSpanDP l (SameLine 0) -noAnnSrcSpanDP1 :: (Monoid ann) => SrcSpan -> SrcSpanAnn' (EpAnn' ann) -noAnnSrcSpanDP1 l = noAnnSrcSpanDP l (DP 0 1) +noAnnSrcSpanDP1 :: (Monoid ann) => SrcSpan -> SrcSpanAnn' (EpAnn ann) +noAnnSrcSpanDP1 l = noAnnSrcSpanDP l (SameLine 1) -noAnnSrcSpanDPn :: (Monoid ann) => SrcSpan -> Int -> SrcSpanAnn' (EpAnn' ann) -noAnnSrcSpanDPn l s = noAnnSrcSpanDP l (DP 0 s) +noAnnSrcSpanDPn :: (Monoid ann) => SrcSpan -> Int -> SrcSpanAnn' (EpAnn ann) +noAnnSrcSpanDPn l s = noAnnSrcSpanDP l (SameLine s) -d0 :: EpaAnchor -d0 = AD $ DP 0 0 +d0 :: EpaLocation +d0 = EpaDelta $ SameLine 0 -d1 :: EpaAnchor -d1 = AD $ DP 0 1 +d1 :: EpaLocation +d1 = EpaDelta $ SameLine 1 -dn :: Int -> EpaAnchor -dn n = AD $ DP 0 n +dn :: Int -> EpaLocation +dn n = EpaDelta $ SameLine n m0 :: AnchorOperation -m0 = MovedAnchor $ DP 0 0 +m0 = MovedAnchor $ SameLine 0 m1 :: AnchorOperation -m1 = MovedAnchor $ DP 0 1 +m1 = MovedAnchor $ SameLine 1 mn :: Int -> AnchorOperation -mn n = MovedAnchor $ DP 0 n +mn n = MovedAnchor $ SameLine n addComma :: SrcSpanAnnA -> SrcSpanAnnA addComma (SrcSpanAnn EpAnnNotUsed l) - = (SrcSpanAnn (EpAnn (spanAsAnchor l) (AnnListItem [AddCommaAnn d0]) noCom) l) + = (SrcSpanAnn (EpAnn (spanAsAnchor l) (AnnListItem [AddCommaAnn d0]) emptyComments) l) addComma (SrcSpanAnn (EpAnn anc (AnnListItem as) cs) l) = (SrcSpanAnn (EpAnn anc (AnnListItem (AddCommaAnn d0:as)) cs) l) @@ -1124,14 +1121,14 @@ instance HasDecls (LocatedA (HsExpr GhcPs)) where (EpAnn a (AnnsLet l i) cs) -> let off = case l of - (AR r) -> LayoutStartCol $ snd $ ss2pos r - (AD (DP 0 _)) -> LayoutStartCol 0 - (AD (DP _ c)) -> LayoutStartCol c + (EpaSpan r) -> LayoutStartCol $ snd $ ss2pos r + (EpaDelta (SameLine _)) -> LayoutStartCol 0 + (EpaDelta (DifferentLine _ c)) -> LayoutStartCol c ex'' = setEntryDPFromAnchor off i ex newDecls'' = case newDecls of [] -> newDecls - (d:ds) -> setEntryDPDecl d (DP 0 0) : ds - in ( EpAnn a (AnnsLet l (addEpaAnchorDelta off lastAnc i)) cs + (d:ds) -> setEntryDPDecl d (SameLine 0) : ds + in ( EpAnn a (AnnsLet l (addEpaLocationDelta off lastAnc i)) cs , ex'' , newDecls'') binds' <- replaceDeclsValbinds WithoutWhere binds newDecls' @@ -1398,26 +1395,26 @@ replaceDeclsValbinds w (EmptyLocalBinds _) new return (HsValBinds an (ValBinds sortKey decs sigs)) oldWhereAnnotation :: (Monad m) - => EpAnn' AnnList -> WithWhere -> RealSrcSpan -> TransformT m (EpAnn' AnnList) + => EpAnn AnnList -> WithWhere -> RealSrcSpan -> TransformT m (EpAnn AnnList) oldWhereAnnotation EpAnnNotUsed ww _oldSpan = do newSpan <- uniqueSrcSpanT let w = case ww of - WithWhere -> [AddEpAnn AnnWhere (AD (DP 0 0))] + WithWhere -> [AddEpAnn AnnWhere (EpaDelta (SameLine 0))] WithoutWhere -> [] - let anc2' = Anchor (rs newSpan) (MovedAnchor (DP 0 1)) + let anc2' = Anchor (rs newSpan) (MovedAnchor (SameLine 1)) (anc, anc2) <- do newSpan' <- uniqueSrcSpanT - return ( Anchor (rs newSpan') (MovedAnchor (DP 1 2)) + return ( Anchor (rs newSpan') (MovedAnchor (DifferentLine 1 2)) , anc2') let an = EpAnn anc (AnnList (Just anc2) Nothing Nothing w []) - noCom + emptyComments return an oldWhereAnnotation (EpAnn anc an cs) ww _oldSpan = do - -- TODO: when we set DP (0,0) for the HsValBinds EpEpaAnchor, change the AnnList anchor to have the correct DP too + -- TODO: when we set DP (0,0) for the HsValBinds EpEpaLocation, change the AnnList anchor to have the correct DP too let (AnnList ancl o c _r t) = an let w = case ww of - WithWhere -> [AddEpAnn AnnWhere (AD (DP 0 0))] + WithWhere -> [AddEpAnn AnnWhere (EpaDelta (SameLine 0))] WithoutWhere -> [] (anc', ancl') <- do case ww of @@ -1428,17 +1425,17 @@ oldWhereAnnotation (EpAnn anc an cs) ww _oldSpan = do cs return an' -newWhereAnnotation :: (Monad m) => WithWhere -> TransformT m (EpAnn' AnnList) +newWhereAnnotation :: (Monad m) => WithWhere -> TransformT m (EpAnn AnnList) newWhereAnnotation ww = do newSpan <- uniqueSrcSpanT - let anc = Anchor (rs newSpan) (MovedAnchor (DP 1 2)) - let anc2 = Anchor (rs newSpan) (MovedAnchor (DP 1 4)) + let anc = Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 2)) + let anc2 = Anchor (rs newSpan) (MovedAnchor (DifferentLine 1 4)) let w = case ww of - WithWhere -> [AddEpAnn AnnWhere (AD (DP 0 0))] + WithWhere -> [AddEpAnn AnnWhere (EpaDelta (SameLine 0))] WithoutWhere -> [] let an = EpAnn anc (AnnList (Just anc2) Nothing Nothing w []) - noCom + emptyComments return an -- --------------------------------------------------------------------- diff --git a/utils/check-exact/Types.hs b/utils/check-exact/Types.hs index 6717e45698..ac9ae10375 100644 --- a/utils/check-exact/Types.hs +++ b/utils/check-exact/Types.hs @@ -17,7 +17,6 @@ import GHC.Driver.Ppr import Data.Data (Data, toConstr,cast) import qualified Data.Map as Map -import qualified Data.Set as Set -- --------------------------------------------------------------------- -- | This structure holds a complete set of annotations for an AST @@ -63,14 +62,10 @@ mkAnnKey ld = type Pos = (Int,Int) -deltaRow, deltaColumn :: DeltaPos -> Int -deltaRow (DP r _) = r -deltaColumn (DP _ c) = c - -- --------------------------------------------------------------------- annNone :: Annotation -annNone = Ann (DP 0 0) [] [] [] Nothing Nothing +annNone = Ann (SameLine 0) [] [] [] Nothing Nothing data Annotation = Ann { @@ -130,132 +125,9 @@ declFun f (L l de) = -- --------------------------------------------------------------------- -data ACS' a = ACS - { acs :: !(Map.Map a Int) -- ^ how many levels each AstContext should - -- propagate down the AST. Removed when it hits zero - } deriving (Show) - -instance Semigroup (ACS' AstContext) where - ACS a <> ACS b = ACS (Map.unionWith max a b) - -- For Data.Map, mappend == union, which is a left-biased replace - -- for key collisions - -instance Monoid (ACS' AstContext) where - mempty = ACS mempty - -type AstContextSet = ACS' AstContext --- data AstContextSet = ACS --- { acs :: !(Map.Map AstContext Int) -- ^ how many levels each AstContext should --- -- propagate down the AST. Removed when it --- -- hits zero --- } deriving (Show) - -defaultACS :: AstContextSet -defaultACS = ACS Map.empty - --- instance Outputable AstContextSet where -instance (Show a) => Outputable (ACS' a) where - ppr x = text $ show x - -data AstContext = -- LambdaExpr - CaseAlt - | NoPrecedingSpace - | HasHiding - | AdvanceLine - | NoAdvanceLine - | Intercalate -- This item may have a list separator following - | InIE -- possible 'type' or 'pattern' - | PrefixOp - | PrefixOpDollar - | InfixOp -- RdrName may be used as an infix operator - | ListStart -- Identifies first element of a list in layout, so its indentation can me managed differently - | ListItem -- Identifies subsequent elements of a list in layout - | TopLevelDecl -- top level declaration - | NoDarrow - | AddVbar - | Deriving - | Parens -- TODO: Not currently used? - | ExplicitNeverActive - | InGadt - | InRecCon - | InClassDecl - | InSpliceDecl - | LeftMost -- Is this the leftmost operator in a chain of OpApps? - | InTypeApp -- HsTyVar in a TYPEAPP context. Has AnnAt - -- TODO:AZ: do we actually need this? - - -- Next four used to identify current list context - | CtxOnly - | CtxFirst - | CtxMiddle - | CtxLast - | CtxPos Int -- 0 for first, increasing for subsequent - - -- Next are used in tellContext to push context up the tree - | FollowingLine - deriving (Eq, Ord, Show) - - -data ListContexts = LC { lcOnly,lcInitial,lcMiddle,lcLast :: !(Set.Set AstContext) } - deriving (Eq,Show) - --- --------------------------------------------------------------------- - data Rigidity = NormalLayout | RigidLayout deriving (Eq, Ord, Show) --- -- --------------------------------------------------------------------- --- -- | This structure holds a complete set of annotations for an AST --- type Anns = Map.Map AnnKey Annotation - --- emptyAnns :: Anns --- emptyAnns = Map.empty - --- -- | For every @Located a@, use the @SrcSpan@ and constructor name of --- -- a as the key, to store the standard annotation. --- -- These are used to maintain context in the AP and EP monads --- data AnnKey = AnnKey SrcSpan AnnConName --- deriving (Eq, Data, Ord) --- deriving instance Ord SrcSpan - --- -- More compact Show instance --- instance Show AnnKey where --- show (AnnKey ss cn) = "AnnKey " ++ showPprUnsafe ss ++ " " ++ show cn - --- mkAnnKeyPrim :: (Data a) => Located a -> AnnKey --- mkAnnKeyPrim (L l a) = AnnKey l (annGetConstr a) - --- mkAnnKeyPrimA :: (Data a) => LocatedA a -> AnnKey --- mkAnnKeyPrimA (L l a) = AnnKey (locA l) (annGetConstr a) --- -- Holds the name of a constructor --- data AnnConName = CN { unConName :: String } --- deriving (Eq, Ord, Data) - --- -- More compact show instance --- instance Show AnnConName where --- show (CN s) = "CN " ++ show s - --- annGetConstr :: (Data a) => a -> AnnConName --- annGetConstr a = CN (show $ toConstr a) - --- -- |Make an unwrapped @AnnKey@ for the @LHsDecl@ case, a normal one otherwise. --- mkAnnKey :: (Data a) => Located a -> AnnKey --- mkAnnKey ld = --- case cast ld :: Maybe (LHsDecl GhcPs) of --- Just d -> declFun mkAnnKeyPrimA d --- Nothing -> mkAnnKeyPrim ld - - --- type Pos = (Int,Int) - --- -- | A relative positions, row then column --- newtype DeltaPos = DP (Int,Int) deriving (Show,Eq,Ord,Data) - --- deltaRow, deltaColumn :: DeltaPos -> Int --- deltaRow (DP (r, _)) = r --- deltaColumn (DP (_, c)) = c - --- --------------------------------------------------------------------- -- | A Haskell comment. The @AnnKeywordId@ is present if it has been converted -- from an @AnnKeywordId@ because the annotation must be interleaved into the diff --git a/utils/check-exact/Utils.hs b/utils/check-exact/Utils.hs index 0ac0bcdf91..e92ce96638 100644 --- a/utils/check-exact/Utils.hs +++ b/utils/check-exact/Utils.hs @@ -37,9 +37,8 @@ import qualified GHC.Types.Name.Occurrence as OccName (OccName(..),pprNameSpaceB import Control.Arrow import qualified Data.Map as Map -import qualified Data.Set as Set import Data.Data hiding ( Fixity ) -import Data.List (foldl', sortBy, elemIndex) +import Data.List (sortBy, elemIndex) import Debug.Trace import Types @@ -82,7 +81,9 @@ warn c _ = c -- | A good delta has no negative values. isGoodDelta :: DeltaPos -> Bool -isGoodDelta (DP ro co) = ro >= 0 && co >= 0 +isGoodDelta (SameLine co) = co >= 0 +isGoodDelta (DifferentLine ro co) = ro > 0 && co >= 0 + -- Note: DifferentLine invariant is ro is nonzero and positive -- | Create a delta from the current position to the start of the given @@ -116,7 +117,7 @@ ss2deltaStart rrs ss = ss2delta ref ss -- | Convert the start of the second @Pos@ to be an offset from the -- first. The assumption is the reference starts before the second @Pos@ pos2delta :: Pos -> Pos -> DeltaPos -pos2delta (refl,refc) (l,c) = DP lo co +pos2delta (refl,refc) (l,c) = deltaPos lo co where lo = l - refl co = if lo == 0 then c - refc @@ -125,14 +126,15 @@ pos2delta (refl,refc) (l,c) = DP lo co -- | Apply the delta to the current position, taking into account the -- current column offset if advancing to a new line undelta :: Pos -> DeltaPos -> LayoutStartCol -> Pos -undelta (l,c) (DP dl dc) (LayoutStartCol co) = (fl,fc) +undelta (l,c) (SameLine dc) (LayoutStartCol _co) = (l, c + dc) +undelta (l,_) (DifferentLine dl dc) (LayoutStartCol co) = (fl,fc) where + -- Note: invariant: dl > 0 fl = l + dl - fc = if dl == 0 then c + dc - else co + dc + fc = co + dc undeltaSpan :: RealSrcSpan -> AnnKeywordId -> DeltaPos -> AddEpAnn -undeltaSpan anchor kw dp = AddEpAnn kw (AR sp) +undeltaSpan anchor kw dp = AddEpAnn kw (EpaSpan sp) where (l,c) = undelta (ss2pos anchor) dp (LayoutStartCol 0) len = length (keywordToString (G kw)) @@ -144,41 +146,16 @@ undeltaSpan anchor kw dp = AddEpAnn kw (AR sp) -- > DP (0, 9) `addDP` DP (1, 5) == DP (1, 5) -- > DP (1, 4) `addDP` DP (1, 3) == DP (2, 3) addDP :: DeltaPos -> DeltaPos -> DeltaPos -addDP (DP a b) (DP c d) = - if c >= 1 then DP (a+c) d - else DP a (b+d) - --- | "Subtract" two @DeltaPos@ from each other, in the sense of calculating the --- remaining delta for the second after the first has been applied. --- invariant : if c = a `addDP` b --- then a `stepDP` c == b --- --- Cases where first DP is <= than second --- > DP (0, 1) `addDP` DP (0, 2) == DP (0, 1) --- > DP (1, 1) `addDP` DP (2, 0) == DP (1, 0) --- > DP (1, 3) `addDP` DP (1, 4) == DP (0, 1) --- > DP (1, 4) `addDP` DP (1, 4) == DP (1, 4) --- --- Cases where first DP is > than second --- > DP (0, 3) `addDP` DP (0, 2) == DP (0,1) -- advance one at least --- > DP (3, 3) `addDP` DP (2, 4) == DP (1, 4) -- go one line forward and to expected col --- > DP (3, 3) `addDP` DP (0, 4) == DP (0, 1) -- maintain col delta at least --- > DP (1, 21) `addDP` DP (1, 4) == DP (1, 4) -- go one line forward and to expected col -stepDP :: DeltaPos -> DeltaPos -> DeltaPos -stepDP (DP a b) (DP c d) - | (a,b) == (c,d) = DP a b - | a == c = if b < d then DP 0 (d - b) - else if d == 0 - then DP 1 0 - else DP c d - | a < c = DP (c - a) d - | otherwise = DP 1 d +addDP dp (DifferentLine c d) = DifferentLine (getDeltaLine dp+c) d +addDP (DifferentLine a b) (SameLine d) = DifferentLine a (b+d) +addDP (SameLine b) (SameLine d) = SameLine (b+d) -- --------------------------------------------------------------------- adjustDeltaForOffset :: Int -> LayoutStartCol -> DeltaPos -> DeltaPos -adjustDeltaForOffset _ _colOffset dp@(DP 0 _) = dp -- same line -adjustDeltaForOffset d (LayoutStartCol colOffset) (DP l c) = DP l (c - colOffset - d) +adjustDeltaForOffset _ _colOffset dp@(SameLine _) = dp +adjustDeltaForOffset d (LayoutStartCol colOffset) (DifferentLine l c) + = DifferentLine l (c - colOffset - d) -- --------------------------------------------------------------------- @@ -283,10 +260,10 @@ normaliseCommentText ('\r':xs) = normaliseCommentText xs normaliseCommentText (x:xs) = x:normaliseCommentText xs -- | Makes a comment which originates from a specific keyword. -mkKWComment :: AnnKeywordId -> EpaAnchor -> Comment -mkKWComment kw (AR ss) +mkKWComment :: AnnKeywordId -> EpaLocation -> Comment +mkKWComment kw (EpaSpan ss) = Comment (keywordToString $ G kw) (Anchor ss UnchangedAnchor) (Just kw) -mkKWComment kw (AD dp) +mkKWComment kw (EpaDelta dp) = Comment (keywordToString $ G kw) (Anchor placeholderRealSpan (MovedAnchor dp)) (Just kw) comment2dp :: (Comment, DeltaPos) -> (KeywordId, DeltaPos) @@ -304,18 +281,9 @@ getAnnotationEP la as = -- start of the current element. annTrueEntryDelta :: Annotation -> DeltaPos annTrueEntryDelta Ann{annEntryDelta, annPriorComments} = - foldr addDP (DP 0 0) (map (\(a, b) -> addDP b (dpFromString $ commentContents a)) annPriorComments ) + foldr addDP (SameLine 0) (map (\(a, b) -> addDP b (dpFromString $ commentContents a)) annPriorComments ) `addDP` annEntryDelta --- | Take an annotation and a required "true entry" and calculate an equivalent --- one relative to the last comment in the annPriorComments. -annCommentEntryDelta :: Annotation -> DeltaPos -> DeltaPos -annCommentEntryDelta Ann{annPriorComments} trueDP = dp - where - commentDP = - foldr addDP (DP 0 0) (map (\(a, b) -> addDP b (dpFromString $ commentContents a)) annPriorComments ) - dp = stepDP commentDP trueDP - -- | Return the DP of the first item that generates output, either a comment or the entry DP annLeadingCommentEntryDelta :: Annotation -> DeltaPos annLeadingCommentEntryDelta Ann{annPriorComments,annEntryDelta} = dp @@ -329,7 +297,10 @@ annLeadingCommentEntryDelta Ann{annPriorComments,annEntryDelta} = dp dpFromString :: String -> DeltaPos dpFromString xs = dpFromString' xs 0 0 where - dpFromString' "" line col = DP line col + dpFromString' "" line col = + if line == 0 + then SameLine col + else DifferentLine line col dpFromString' ('\n': cs) line _ = dpFromString' cs (line + 1) 0 dpFromString' (_:cs) line col = dpFromString' cs line (col + 1) @@ -355,56 +326,6 @@ name2String = showPprUnsafe -- --------------------------------------------------------------------- --- | Put the provided context elements into the existing set with fresh level --- counts -setAcs :: Set.Set AstContext -> AstContextSet -> AstContextSet -setAcs ctxt acs = setAcsWithLevel ctxt 3 acs - --- | Put the provided context elements into the existing set with given level --- counts --- setAcsWithLevel :: Set.Set AstContext -> Int -> AstContextSet -> AstContextSet --- setAcsWithLevel ctxt level (ACS a) = ACS a' --- where --- upd s (k,v) = Map.insert k v s --- a' = foldl' upd a $ zip (Set.toList ctxt) (repeat level) -setAcsWithLevel :: (Ord a) => Set.Set a -> Int -> ACS' a -> ACS' a -setAcsWithLevel ctxt level (ACS a) = ACS a' - where - upd s (k,v) = Map.insert k v s - a' = foldl' upd a $ zip (Set.toList ctxt) (repeat level) - --- --------------------------------------------------------------------- --- | Remove the provided context element from the existing set --- unsetAcs :: AstContext -> AstContextSet -> AstContextSet -unsetAcs :: (Ord a) => a -> ACS' a -> ACS' a -unsetAcs ctxt (ACS a) = ACS $ Map.delete ctxt a - --- --------------------------------------------------------------------- - --- | Are any of the contexts currently active? --- inAcs :: Set.Set AstContext -> AstContextSet -> Bool -inAcs :: (Ord a) => Set.Set a -> ACS' a -> Bool -inAcs ctxt (ACS a) = not $ Set.null $ Set.intersection ctxt (Set.fromList $ Map.keys a) - --- | propagate the ACS down a level, dropping all values which hit zero --- pushAcs :: AstContextSet -> AstContextSet -pushAcs :: ACS' a -> ACS' a -pushAcs (ACS a) = ACS $ Map.mapMaybe f a - where - f n - | n <= 1 = Nothing - | otherwise = Just (n - 1) - --- |Sometimes we have to pass the context down unchanged. Bump each count up by --- one so that it is unchanged after a @pushAcs@ call. --- bumpAcs :: AstContextSet -> AstContextSet -bumpAcs :: ACS' a -> ACS' a -bumpAcs (ACS a) = ACS $ Map.mapMaybe f a - where - f n = Just (n + 1) - --- --------------------------------------------------------------------- - occAttributes :: OccName.OccName -> String occAttributes o = "(" ++ ns ++ vo ++ tv ++ tc ++ d ++ ds ++ s ++ v ++ ")" where @@ -418,14 +339,6 @@ occAttributes o = "(" ++ ns ++ vo ++ tv ++ tc ++ d ++ ds ++ s ++ v ++ ")" s = if isSymOcc o then "Sym " else "" v = if isValOcc o then "Val " else "" -{- -data NameSpace = VarName -- Variables, including "real" data constructors - | DataName -- "Source" data constructors - | TvName -- Type variables - | TcClsName -- Type constructors and classes; Haskell has them - -- in the same name space for now. --} - -- --------------------------------------------------------------------- locatedAnAnchor :: LocatedAn a t -> RealSrcSpan @@ -434,15 +347,6 @@ locatedAnAnchor (L (SrcSpanAnn (EpAnn a _ _) _) _) = anchor a -- --------------------------------------------------------------------- --- showSDoc_ :: SDoc -> String --- showSDoc_ = showSDoc unsafeGlobalDynFlags - --- showSDocDebug_ :: SDoc -> String --- showSDocDebug_ = showSDocDebug unsafeGlobalDynFlags - - - -- --------------------------------------------------------------------- - showAst :: (Data a) => a -> String showAst ast = showSDocUnsafe diff --git a/utils/haddock b/utils/haddock -Subproject dabdee145c8da12aff4eebce7847f2af1a2ddc1 +Subproject cafb48118f7c111020663776845897e225607b4 |