ghc 9.2.2 → 9.2.3
raw patch · 58 files changed
+961/−538 lines, 58 filesdep ~ghc-bootdep ~ghc-heapdep ~ghci
Dependency ranges changed: ghc-boot, ghc-heap, ghci
Files
- GHC/Cmm/Info/Build.hs +85/−41
- GHC/CmmToAsm.hs +8/−5
- GHC/CmmToAsm/X86/Regs.hs +3/−3
- GHC/CmmToC.hs +34/−31
- GHC/CmmToLlvm/CodeGen.hs +31/−29
- GHC/Core/Opt/Arity.hs +2/−1
- GHC/Core/Opt/ConstantFold.hs +1/−1
- GHC/Core/Opt/OccurAnal.hs +24/−10
- GHC/Core/Opt/Simplify/Monad.hs +0/−1
- GHC/Core/Opt/SpecConstr.hs +1/−2
- GHC/Core/TyCo/Rep.hs +0/−1
- GHC/Core/TyCon.hs +8/−0
- GHC/Data/IOEnv.hs +0/−1
- GHC/Data/Maybe.hs +4/−1
- GHC/Data/Stream.hs +0/−1
- GHC/Driver/CodeOutput.hs +9/−0
- GHC/Driver/Main.hs +3/−4
- GHC/Hs/Binds.hs +0/−1
- GHC/Hs/Decls.hs +8/−10
- GHC/Hs/Pat.hs +9/−12
- GHC/Hs/Type.hs +9/−11
- GHC/HsToCore/Expr.hs +2/−2
- GHC/HsToCore/Utils.hs +5/−1
- GHC/IfaceToCore.hs +1/−1
- GHC/Parser/PostProcess.hs +8/−8
- GHC/Rename/Env.hs +1/−3
- GHC/Rename/Utils.hs +5/−2
- GHC/Runtime/Eval.hs +0/−1
- GHC/Runtime/Interpreter.hs +4/−2
- GHC/Settings/Config.hs +1/−1
- GHC/Stg/Unarise.hs +23/−1
- GHC/StgToCmm/DataCon.hs +0/−1
- GHC/StgToCmm/Monad.hs +1/−3
- GHC/StgToCmm/Prim.hs +2/−0
- GHC/Tc/Errors.hs +5/−5
- GHC/Tc/Gen/Bind.hs +2/−2
- GHC/Tc/Gen/Sig.hs +39/−17
- GHC/Tc/Instance/Typeable.hs +1/−2
- GHC/Tc/Module.hs +30/−7
- GHC/Tc/Solver.hs +74/−28
- GHC/Tc/Solver/Canonical.hs +86/−54
- GHC/Tc/Solver/Interact.hs +129/−66
- GHC/Tc/Solver/Monad.hs +79/−31
- GHC/Tc/TyCl/Instance.hs +5/−4
- GHC/Tc/TyCl/PatSyn.hs +79/−33
- GHC/Tc/TyCl/PatSyn.hs-boot +5/−5
- GHC/Tc/Types/Origin.hs +53/−13
- GHC/Tc/Utils/TcMType.hs +22/−12
- GHC/Tc/Utils/TcType.hs +1/−1
- GHC/ThToHs.hs +9/−10
- GHC/Types/Unique/Supply.hs +1/−2
- Language/Haskell/Syntax.hs +3/−6
- Language/Haskell/Syntax/Binds.hs +0/−2
- Language/Haskell/Syntax/Decls.hs +7/−9
- Language/Haskell/Syntax/Expr.hs +9/−11
- Language/Haskell/Syntax/Pat.hs +9/−12
- Language/Haskell/Syntax/Type.hs +8/−10
- ghc.cabal +13/−4
GHC/Cmm/Info/Build.hs view
@@ -367,8 +367,41 @@ -} -- ----------------------------------------------------------------------{- Note [Invalid optimisation: shortcutting]+{-+Note [No static object resurrection]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The "static flag" mechanism (see Note [STATIC_LINK fields] in smStorage.h) that+the GC uses to track liveness of static objects assumes that unreachable+objects will never become reachable again (i.e. are never "resurrected").+Breaking this assumption can result in extremely subtle GC soundness issues+(e.g. #15544, #20959). +Guaranteeing that this assumption is not violated requires that all CAFfy+static objects reachable from the object's code are reachable from its SRT. In+the past we have gotten this wrong in a few ways:++ * shortcutting references to FUN_STATICs to instead point to the FUN_STATIC's+ SRT. This lead to #15544 and is described in more detail in Note [Invalid+ optimisation: shortcutting].++ * omitting references to static data constructor applications. This previously+ happened due to an oversight (#20959): when generating an SRT for a+ recursive group we would drop references to the CAFfy static data+ constructors.++To see why we cannot allow object resurrection, see the examples in the+above-mentioned Notes.++If a static closure definitely does not transitively refer to any CAFs, then it+*may* be advertised as not-CAFfy in the interface file and consequently *may*+be omitted from SRTs. Regardless of whether the closure is advertised as CAFfy+or non-CAFfy, its STATIC_LINK field *must* be set to 3, so that it never+appears on the static closure list.+-}++{-+Note [Invalid optimisation: shortcutting]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ You might think that if we have something like A's SRT = {B}@@ -392,12 +425,12 @@ point to B, so that it keeps B alive. 2. B is a function. This is the tricky one. The reason we can't-shortcut in this case is that we aren't allowed to resurrect static-objects.+ shortcut in this case is that we aren't allowed to resurrect static+ objects for the reason described in Note [No static object resurrection].+ We noticed this in #15544. -== How does this cause a problem? ==+The particular case that cropped up when we tried this in #15544 was: -The particular case that cropped up when we tried this was #15544. - A is a thunk - B is a static function - X is a CAF@@ -414,16 +447,10 @@ - In practice, the GC thinks that B has already been visited, and so doesn't visit X, and catastrophe ensues. -== Isn't this caused by the RET_FUN business? == -Maybe, but could you prove that RET_FUN is the only way that-resurrection can occur? -So, no shortcutting.- Note [Ticky labels in SRT analysis] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- Raw Cmm data (CmmStaticsRaw) can't contain pointers so they're considered non-CAFFY in SRT analysis and we update the SRTMap mapping them to `Nothing` (meaning they're not CAFFY).@@ -469,6 +496,9 @@ type CAFSet = Set CAFLabel type CAFEnv = LabelMap CAFSet +-- | Records the CAFfy references of a set of static data decls.+type DataCAFEnv = Map CLabel CAFSet+ mkCAFLabel :: Platform -> CLabel -> CAFLabel mkCAFLabel platform lbl = CAFLabel (toClosureLbl platform lbl) @@ -783,7 +813,7 @@ -- Ignore the original grouping of decls, and combine all the -- CAFEnvs into a single CAFEnv.- let static_data_env :: Map CLabel CAFSet+ let static_data_env :: DataCAFEnv static_data_env = Map.fromList $ flip map data_ $@@ -796,9 +826,6 @@ CmmStatics lbl _ _ _ -> (lbl, set) CmmStaticsRaw lbl _ -> (lbl, set) - static_data :: Set CLabel- static_data = Map.keysSet static_data_env- (proc_envs, procss) = unzip procs cafEnv = mapUnions proc_envs decls = map snd data_ ++ concat procss@@ -837,10 +864,10 @@ (result, moduleSRTInfo') = initUs_ us $ flip runStateT moduleSRTInfo $ do- nonCAFs <- mapM (doSCC dflags staticFuns static_data) sccs+ nonCAFs <- mapM (doSCC dflags staticFuns static_data_env) sccs cAFs <- forM cafsWithSRTs $ \(l, cafLbl, cafs) -> oneSRT dflags staticFuns [BlockLabel l] [cafLbl]- True{-is a CAF-} cafs static_data+ True{-is a CAF-} cafs static_data_env return (nonCAFs ++ cAFs) (srt_declss, pairs, funSRTs, has_caf_refs) = unzip4 result@@ -883,7 +910,7 @@ doSCC :: DynFlags -> LabelMap CLabel -- which blocks are static function entry points- -> Set CLabel -- static data+ -> DataCAFEnv -- ^ static data -> SCC (SomeLabel, CAFLabel, Set CAFLabel) -> StateT ModuleSRTInfo UniqSM ( [CmmDeclSRTs] -- generated SRTs@@ -892,14 +919,14 @@ , Bool -- Whether the group has CAF references ) -doSCC dflags staticFuns static_data (AcyclicSCC (l, cafLbl, cafs)) =- oneSRT dflags staticFuns [l] [cafLbl] False cafs static_data+doSCC dflags staticFuns static_data_env (AcyclicSCC (l, cafLbl, cafs)) =+ oneSRT dflags staticFuns [l] [cafLbl] False cafs static_data_env -doSCC dflags staticFuns static_data (CyclicSCC nodes) = do+doSCC dflags staticFuns static_data_env (CyclicSCC nodes) = do -- build a single SRT for the whole cycle, see Note [recursive SRTs] let (lbls, caf_lbls, cafsets) = unzip3 nodes cafs = Set.unions cafsets- oneSRT dflags staticFuns lbls caf_lbls False cafs static_data+ oneSRT dflags staticFuns lbls caf_lbls False cafs static_data_env {- Note [recursive SRTs]@@ -911,19 +938,24 @@ However, there are a couple of wrinkles to be aware of. -* The Set CAFLabel for this SRT will contain labels in the group-itself. The SRTMap will therefore not contain entries for these labels-yet, so we can't turn them into SRTEntries using resolveCAF. BUT we-can just remove recursive references from the Set CAFLabel before-generating the SRT - the SRT will still contain all the CAFLabels that-we need to refer to from this group's SRT.+* The Set CAFfyLabel for this SRT will contain labels in the group+ itself. The SRTMap will therefore not contain entries for these labels+ yet, so we can't turn them into SRTEntries using resolveCAF. BUT we+ can just remove recursive references from the Set CAFLabel before+ generating the SRT - the group SRT will consist of the union of the SRTs of+ each of group's constituents minus recursive references. -* That is, EXCEPT for static function closures. For the same reason-described in Note [Invalid optimisation: shortcutting], we cannot omit-references to static function closures.- - But, since we will merge the SRT with one of the static function- closures (see [FUN]), we can omit references to *that* static- function closure from the SRT.+* That is, EXCEPT for static function closures and static data constructor+ applications. For the same reason described in Note [No static object+ resurrection], we cannot omit references to static function closures and+ constructor applications.++ But, since we will merge the SRT with one of the static function+ closures (see [FUN]), we can omit references to *that* static+ function closure from the SRT.++* Similarly, we must reintroduce recursive references to static data+ constructor applications into the group's SRT. -} -- | Build an SRT for a set of blocks@@ -934,7 +966,7 @@ -> [CAFLabel] -- labels for those blocks -> Bool -- True <=> this SRT is for a CAF -> Set CAFLabel -- SRT for this set- -> Set CLabel -- Static data labels in this group+ -> DataCAFEnv -- Static data labels in this group -> StateT ModuleSRTInfo UniqSM ( [CmmDeclSRTs] -- SRT objects we built , [(Label, CLabel)] -- SRT fields for these blocks' itbls@@ -942,7 +974,7 @@ , Bool -- Whether the group has CAF references ) -oneSRT dflags staticFuns lbls caf_lbls isCAF cafs static_data = do+oneSRT dflags staticFuns lbls caf_lbls isCAF cafs static_data_env = do topSRT <- get let@@ -962,7 +994,10 @@ [] -> (Nothing, []) ((l,b):xs) -> (Just (l,b), map fst xs) - -- Remove recursive references from the SRT+ -- Remove recursive references from the SRT as described in+ -- Note [recursive SRTs]. We carefully reintroduce references to static+ -- functions and data constructor applications below, as is necessary due+ -- to Note [No static object resurrection]. nonRec :: Set CAFLabel nonRec = cafs `Set.difference` Set.fromList caf_lbls @@ -984,7 +1019,7 @@ text "nonRec:" <+> pdoc platform nonRec $$ text "lbls:" <+> pdoc platform lbls $$ text "caf_lbls:" <+> pdoc platform caf_lbls $$- text "static_data:" <+> pdoc platform static_data $$+ text "static_data_env:" <+> pdoc platform static_data_env $$ text "cafs:" <+> pdoc platform cafs $$ text "blockids:" <+> ppr blockids $$ text "maybeFunClosure:" <+> pdoc platform maybeFunClosure $$@@ -1011,7 +1046,7 @@ foldl' (\srt_map cafLbl@(CAFLabel clbl) -> -- Only map static data to Nothing (== not CAFFY). For CAFFY -- statics we refer to the static itself instead of a SRT.- if not (Set.member clbl static_data) || isNothing srtEntry then+ if not (Map.member clbl static_data_env) || isNothing srtEntry then Map.insert cafLbl srtEntry srt_map else srt_map)@@ -1021,7 +1056,7 @@ state{ moduleSRTMap = srt_map } allStaticData =- all (\(CAFLabel clbl) -> Set.member clbl static_data) caf_lbls+ all (\(CAFLabel clbl) -> Map.member clbl static_data_env) caf_lbls if Set.null filtered0 then do srtTraceM "oneSRT: empty" (pdoc platform caf_lbls)@@ -1032,7 +1067,16 @@ -- references in the group. See Note [recursive SRTs]. let allBelow_funs = Set.fromList (map (SRTEntry . toClosureLbl platform) otherFunLabels)- let filtered = filtered0 `Set.union` allBelow_funs+ -- We must also ensure that all CAFfy static data constructor applications+ -- are included. See Note [recursive SRTs] and #20959.+ let allBelow_data =+ Set.fromList+ [ SRTEntry $ toClosureLbl platform lbl+ | DeclLabel lbl <- lbls+ , Just refs <- pure $ Map.lookup lbl static_data_env+ , not $ Set.null refs+ ]+ let filtered = filtered0 `Set.union` allBelow_funs `Set.union` allBelow_data srtTraceM "oneSRT" (text "filtered:" <+> pdoc platform filtered $$ text "allBelow_funs:" <+> pdoc platform allBelow_funs) case Set.toList filtered of
GHC/CmmToAsm.hs view
@@ -5,13 +5,16 @@ -- -- ----------------------------------------------------------------------------- -{-# LANGUAGE BangPatterns, CPP, GADTs, ScopedTypeVariables, PatternSynonyms,- DeriveFunctor #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
GHC/CmmToAsm/X86/Regs.hs view
@@ -390,9 +390,9 @@ | target32Bit platform = [eax,ecx,edx] ++ map regSingle (floatregnos platform) | platformOS platform == OSMinGW32 = [rax,rcx,rdx,r8,r9,r10,r11]- -- Only xmm0-5 are caller-saves registers on 64bit windows.- -- ( https://docs.microsoft.com/en-us/cpp/build/register-usage )- -- For details check the Win64 ABI.+ -- Only xmm0-5 are caller-saves registers on 64-bit windows.+ -- For details check the Win64 ABI:+ -- https://docs.microsoft.com/en-us/cpp/build/x64-software-conventions ++ map xmm [0 .. 5] | otherwise -- all xmm regs are caller-saves
GHC/CmmToC.hs view
@@ -955,40 +955,43 @@ MO_SubIntC {} -> unsupported MO_U_Mul2 {} -> unsupported MO_Touch -> unsupported+ -- we could support prefetch via "__builtin_prefetch"+ -- Not adding it for now (MO_Prefetch_Data _ ) -> unsupported- --- we could support prefetch via "__builtin_prefetch"- --- Not adding it for now- MO_I64_ToI -> unsupported- MO_I64_FromI -> unsupported- MO_W64_ToW -> unsupported- MO_W64_FromW -> unsupported- MO_x64_Neg -> unsupported- MO_x64_Add -> unsupported- MO_x64_Sub -> unsupported- MO_x64_Mul -> unsupported- MO_I64_Quot -> unsupported- MO_I64_Rem -> unsupported- MO_W64_Quot -> unsupported- MO_W64_Rem -> unsupported- MO_x64_And -> unsupported- MO_x64_Or -> unsupported- MO_x64_Xor -> unsupported- MO_x64_Not -> unsupported- MO_x64_Shl -> unsupported- MO_I64_Shr -> unsupported- MO_W64_Shr -> unsupported- MO_x64_Eq -> unsupported- MO_x64_Ne -> unsupported- MO_I64_Ge -> unsupported- MO_I64_Gt -> unsupported- MO_I64_Le -> unsupported- MO_I64_Lt -> unsupported- MO_W64_Ge -> unsupported- MO_W64_Gt -> unsupported- MO_W64_Le -> unsupported- MO_W64_Lt -> unsupported++ MO_I64_ToI -> dontReach64+ MO_I64_FromI -> dontReach64+ MO_W64_ToW -> dontReach64+ MO_W64_FromW -> dontReach64+ MO_x64_Neg -> dontReach64+ MO_x64_Add -> dontReach64+ MO_x64_Sub -> dontReach64+ MO_x64_Mul -> dontReach64+ MO_I64_Quot -> dontReach64+ MO_I64_Rem -> dontReach64+ MO_W64_Quot -> dontReach64+ MO_W64_Rem -> dontReach64+ MO_x64_And -> dontReach64+ MO_x64_Or -> dontReach64+ MO_x64_Xor -> dontReach64+ MO_x64_Not -> dontReach64+ MO_x64_Shl -> dontReach64+ MO_I64_Shr -> dontReach64+ MO_W64_Shr -> dontReach64+ MO_x64_Eq -> dontReach64+ MO_x64_Ne -> dontReach64+ MO_I64_Ge -> dontReach64+ MO_I64_Gt -> dontReach64+ MO_I64_Le -> dontReach64+ MO_I64_Lt -> dontReach64+ MO_W64_Ge -> dontReach64+ MO_W64_Gt -> dontReach64+ MO_W64_Le -> dontReach64+ MO_W64_Lt -> dontReach64 where unsupported = panic ("pprCallishMachOp_for_C: " ++ show mop ++ " not supported!")+ dontReach64 = panic ("pprCallishMachOp_for_C: " ++ show mop+ ++ " should be not be encountered because the regular primop for this 64-bit operation is used instead.") -- --------------------------------------------------------------------- -- Useful #defines
GHC/CmmToLlvm/CodeGen.hs view
@@ -807,6 +807,8 @@ intrinTy2 = "p0i8." ++ showSDoc dflags (ppr $ llvmWord platform) unsupported = panic ("cmmPrimOpFunctions: " ++ show mop ++ " not supported here")+ dontReach64 = panic ("cmmPrimOpFunctions: " ++ show mop+ ++ " should be not be encountered because the regular primop for this 64-bit operation is used instead.") return $ case mop of MO_F32_Exp -> fsLit "expf"@@ -908,35 +910,35 @@ MO_Cmpxchg _ -> unsupported MO_Xchg _ -> unsupported - MO_I64_ToI -> fsLit "hs_int64ToInt"- MO_I64_FromI -> fsLit "hs_intToInt64"- MO_W64_ToW -> fsLit "hs_word64ToWord"- MO_W64_FromW -> fsLit "hs_wordToWord64"- MO_x64_Neg -> fsLit "hs_neg64"- MO_x64_Add -> fsLit "hs_add64"- MO_x64_Sub -> fsLit "hs_sub64"- MO_x64_Mul -> fsLit "hs_mul64"- MO_I64_Quot -> fsLit "hs_quotInt64"- MO_I64_Rem -> fsLit "hs_remInt64"- MO_W64_Quot -> fsLit "hs_quotWord64"- MO_W64_Rem -> fsLit "hs_remWord64"- MO_x64_And -> fsLit "hs_and64"- MO_x64_Or -> fsLit "hs_or64"- MO_x64_Xor -> fsLit "hs_xor64"- MO_x64_Not -> fsLit "hs_not64"- MO_x64_Shl -> fsLit "hs_uncheckedShiftL64"- MO_I64_Shr -> fsLit "hs_uncheckedIShiftRA64"- MO_W64_Shr -> fsLit "hs_uncheckedShiftRL64"- MO_x64_Eq -> fsLit "hs_eq64"- MO_x64_Ne -> fsLit "hs_ne64"- MO_I64_Ge -> fsLit "hs_geInt64"- MO_I64_Gt -> fsLit "hs_gtInt64"- MO_I64_Le -> fsLit "hs_leInt64"- MO_I64_Lt -> fsLit "hs_ltInt64"- MO_W64_Ge -> fsLit "hs_geWord64"- MO_W64_Gt -> fsLit "hs_gtWord64"- MO_W64_Le -> fsLit "hs_leWord64"- MO_W64_Lt -> fsLit "hs_ltWord64"+ MO_I64_ToI -> dontReach64+ MO_I64_FromI -> dontReach64+ MO_W64_ToW -> dontReach64+ MO_W64_FromW -> dontReach64+ MO_x64_Neg -> dontReach64+ MO_x64_Add -> dontReach64+ MO_x64_Sub -> dontReach64+ MO_x64_Mul -> dontReach64+ MO_I64_Quot -> dontReach64+ MO_I64_Rem -> dontReach64+ MO_W64_Quot -> dontReach64+ MO_W64_Rem -> dontReach64+ MO_x64_And -> dontReach64+ MO_x64_Or -> dontReach64+ MO_x64_Xor -> dontReach64+ MO_x64_Not -> dontReach64+ MO_x64_Shl -> dontReach64+ MO_I64_Shr -> dontReach64+ MO_W64_Shr -> dontReach64+ MO_x64_Eq -> dontReach64+ MO_x64_Ne -> dontReach64+ MO_I64_Ge -> dontReach64+ MO_I64_Gt -> dontReach64+ MO_I64_Le -> dontReach64+ MO_I64_Lt -> dontReach64+ MO_W64_Ge -> dontReach64+ MO_W64_Gt -> dontReach64+ MO_W64_Le -> dontReach64+ MO_W64_Lt -> dontReach64 -- | Tail function calls
GHC/Core/Opt/Arity.hs view
@@ -1709,7 +1709,8 @@ (mkCast (Var x') co1) in Just (x', substExpr subst e `mkCast` co2) | otherwise- = pprTrace "exprIsLambda_maybe: Unexpected lambda in case" (ppr (Lam x e))+ -- See #21555 / #21577 for a case where this trace fired but the cause was benign+ = -- pprTrace "exprIsLambda_maybe: Unexpected lambda in case" (ppr (Lam x e)) Nothing pushCoDataCon :: DataCon -> [CoreExpr] -> Coercion
GHC/Core/Opt/ConstantFold.hs view
@@ -10,8 +10,8 @@ (i1 + i2) only if it results in a valid Float. -} -{-# LANGUAGE CPP #-} {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-}
GHC/Core/Opt/OccurAnal.hs view
@@ -857,14 +857,14 @@ (final_uds, loop_breaker_nodes) = mkLoopBreakerNodes env lvl body_uds details_s ------------------------------- active_rule_fvs :: VarSet- active_rule_fvs = mapUnionVarSet nd_active_rule_fvs details_s+ weak_fvs :: VarSet+ weak_fvs = mapUnionVarSet nd_weak_fvs details_s --------------------------- -- Now reconstruct the cycle pairs :: [(Id,CoreExpr)]- pairs | all_simple = reOrderNodes 0 active_rule_fvs loop_breaker_nodes []- | otherwise = loopBreakNodes 0 active_rule_fvs loop_breaker_nodes []+ pairs | all_simple = reOrderNodes 0 weak_fvs loop_breaker_nodes []+ | otherwise = loopBreakNodes 0 weak_fvs loop_breaker_nodes [] -- In the common case when all are "simple" (no rules at all) -- the loop_breaker_nodes will include all the scope edges -- so a SCC computation would yield a single CyclicSCC result;@@ -954,8 +954,7 @@ h = h_rhs g = h- ...more...- }+ ...more... } Remember that we simplify the RULES before any RHS (see Note [Rules are visible in their own rec group] above).@@ -979,8 +978,12 @@ We "solve" this by: Make q a "weak" loop breaker (OccInfo = IAmLoopBreaker True)- iff q is a mentioned in the RHS of an active RULE in the Rec group+ iff q is a mentioned in the RHS of any RULE (active on not)+ in the Rec group +Note the "active or not" comment; even if a RULE is inactive, we+want its RHS free vars to stay alive (#20820)!+ A normal "strong" loop breaker has IAmLoopBreaker False. So: Inline postInlineUnconditionally@@ -995,8 +998,8 @@ q into p's RULE. That trivial binding for q will hang around until we discard the rule. Yuk. But it's rare. - Note [Rules and loop breakers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [Rules and loop breakers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we form the loop-breaker graph (Step 4 in Note [Recursive bindings: the grand plan]), we must be careful about RULEs. @@ -1016,7 +1019,7 @@ h has a RULE that mentions f then we *must* choose f to be a loop breaker. Example: see Note-[Specialisation rules]. So out plan is this:+[Specialisation rules]. So our plan is this: Take the free variables of f's RHS, and augment it with all the variables reachable by a transitive sequence RULES from those@@ -1322,8 +1325,13 @@ -- If all nodes are simple we don't need a loop-breaker -- dep-anal before reconstructing. + , nd_weak_fvs :: IdSet -- Variables bound in this Rec group that are free+ -- in the RHS of any rule (active or not) for this bndr+ -- See Note [Weak loop breakers]+ , nd_active_rule_fvs :: IdSet -- Variables bound in this Rec group that are free -- in the RHS of an active rule for this bndr+ -- See Note [Rules and loop breakers] , nd_score :: NodeScore }@@ -1368,6 +1376,7 @@ , nd_uds = scope_uds , nd_inl = inl_fvs , nd_simple = null rules_w_uds && null imp_rule_info+ , nd_weak_fvs = weak_fvs , nd_active_rule_fvs = active_rule_fvs , nd_score = pprPanic "makeNodeDetails" (ppr bndr) } @@ -1425,6 +1434,7 @@ rule_uds = foldr add_rule_uds imp_rule_uds rules_w_uds add_rule_uds (_, l, r) uds = l `andUDs` r `andUDs` uds + -------- active_rule_fvs ------------ active_rule_fvs = foldr add_active_rule imp_rule_fvs rules_w_uds add_active_rule (rule, _, rhs_uds) fvs | is_active (ruleActivation rule)@@ -1432,6 +1442,10 @@ | otherwise = fvs + -------- weak_fvs ------------+ -- See Note [Weak loop breakers]+ weak_fvs = foldr add_rule emptyVarSet rules_w_uds+ add_rule (_, _, rhs_uds) fvs = udFreeVars bndr_set rhs_uds `unionVarSet` fvs mkLoopBreakerNodes :: OccEnv -> TopLevelFlag -> UsageDetails -- for BODY of let
GHC/Core/Opt/Simplify/Monad.hs view
@@ -5,7 +5,6 @@ \section[GHC.Core.Opt.Simplify.Monad]{The simplifier Monad} -} -{-# LANGUAGE DeriveFunctor #-} module GHC.Core.Opt.Simplify.Monad ( -- The monad SimplM,
GHC/Core/Opt/SpecConstr.hs view
@@ -36,7 +36,7 @@ import GHC.Core.Coercion hiding( substCo ) import GHC.Core.Rules import GHC.Core.Type hiding ( substTy )-import GHC.Core.TyCon ( tyConUnique, tyConName )+import GHC.Core.TyCon (TyCon, tyConUnique, tyConName ) import GHC.Core.Multiplicity import GHC.Types.Id import GHC.Core.Ppr ( pprParendExpr )@@ -65,7 +65,6 @@ import Data.List (nubBy, sortBy, partition) import GHC.Builtin.Names ( specTyConKey ) import GHC.Unit.Module-import GHC.Core.TyCon ( TyCon ) import GHC.Exts( SpecConstrAnnotation(..) ) import Data.Ord( comparing )
GHC/Core/TyCo/Rep.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE MultiWayIf #-} {-# OPTIONS_HADDOCK not-home #-}
GHC/Core/TyCon.hs view
@@ -52,6 +52,7 @@ isPrimTyCon, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, isUnboxedSumTyCon, isPromotedTupleTyCon,+ isLiftedAlgTyCon, isTypeSynonymTyCon, mustBeSaturated, isPromotedDataCon, isPromotedDataCon_maybe,@@ -147,6 +148,8 @@ ( DataCon, dataConFieldLabels , dataConTyCon, dataConFullSig , isUnboxedSumDataCon )+import {-# SOURCE #-} GHC.Core.Type+ ( isLiftedTypeKind ) import GHC.Builtin.Uniques ( tyConRepNameUnique , dataConTyRepNameUnique )@@ -2190,6 +2193,11 @@ | SumTyCon {} <- rhs = True isUnboxedSumTyCon _ = False++isLiftedAlgTyCon :: TyCon -> Bool+isLiftedAlgTyCon (AlgTyCon { tyConResKind = res_kind })+ = isLiftedTypeKind res_kind+isLiftedAlgTyCon _ = False -- | Is this the 'TyCon' for a /promoted/ tuple? isPromotedTupleTyCon :: TyCon -> Bool
GHC/Data/IOEnv.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE PatternSynonyms #-} --
GHC/Data/Maybe.hs view
@@ -33,6 +33,7 @@ import Data.Maybe import Data.Foldable ( foldlM ) import GHC.Utils.Misc (HasCallStack)+import Data.List.NonEmpty ( NonEmpty ) infixr 4 `orElse` @@ -49,8 +50,10 @@ -- | Takes a list of @Maybes@ and returns the first @Just@ if there is one, or -- @Nothing@ otherwise.-firstJusts :: [Maybe a] -> Maybe a+firstJusts :: Foldable f => f (Maybe a) -> Maybe a firstJusts = msum+{-# SPECIALISE firstJusts :: [Maybe a] -> Maybe a #-}+{-# SPECIALISE firstJusts :: NonEmpty (Maybe a) -> Maybe a #-} -- | Takes computations returnings @Maybes@; tries each one in order. -- The first one to return a @Just@ wins. Returns @Nothing@ if all computations
GHC/Data/Stream.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TupleSections #-} -- ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow 2012
GHC/Driver/CodeOutput.hs view
@@ -199,6 +199,15 @@ ************************************************************************ -} +{-+Note [Packaging libffi headers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The C code emitted by GHC for libffi adjustors must depend upon the ffi_arg type,+defined in <ffi.h>. For this reason, we must ensure that <ffi.h> is available+in binary distributions. To do so, we install these headers as part of the+`rts` package.+-}+ outputForeignStubs :: Logger -> TmpFs
GHC/Driver/Main.hs view
@@ -1,8 +1,7 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE ViewPatterns #-}+ {-# OPTIONS_GHC -fprof-auto-top #-} -------------------------------------------------------------------------------
GHC/Hs/Binds.hs view
@@ -8,7 +8,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension-{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-orphans #-} -- Outputable
GHC/Hs/Decls.hs view
@@ -1,17 +1,15 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension -{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable+{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable {- (c) The University of Glasgow 2006
GHC/Hs/Pat.hs view
@@ -1,17 +1,14 @@--{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension-{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-orphans #-} -- Outputable
GHC/Hs/Type.hs view
@@ -1,15 +1,13 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension {-# OPTIONS_GHC -Wno-orphans #-} -- NamedThing, Outputable, OutputableBndrId
GHC/HsToCore/Expr.hs view
@@ -209,8 +209,8 @@ = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun)) Nothing matches ; MASSERT( null args ) -- Functions aren't lifted- ; MASSERT( isIdHsWrapper co_fn )- ; let rhs' = mkOptTickBox tick rhs+ ; core_wrap <- dsHsWrapper co_fn -- Can be non-identity (#21516)+ ; let rhs' = core_wrap (mkOptTickBox tick rhs) ; return (bindNonRec fun rhs' body) } dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss
GHC/HsToCore/Utils.hs view
@@ -614,6 +614,7 @@ ------ Special case (B) ------- For a pattern that is essentially just a tuple: * A product type, so cannot fail+ * Boxed, so that it can be matched lazily * Only one level, so that - generating multiple matches is fine - seq'ing it evaluates the same as matching it@@ -790,6 +791,7 @@ strip_bangs lp = lp is_flat_prod_lpat :: LPat GhcTc -> Bool+-- Pattern is equivalent to a flat, boxed, lifted tuple is_flat_prod_lpat = is_flat_prod_pat . unLoc is_flat_prod_pat :: Pat GhcTc -> Bool@@ -798,7 +800,9 @@ is_flat_prod_pat (ConPat { pat_con = L _ pcon , pat_args = ps}) | RealDataCon con <- pcon- , Just _ <- tyConSingleDataCon_maybe (dataConTyCon con)+ , let tc = dataConTyCon con+ , Just _ <- tyConSingleDataCon_maybe tc+ , isLiftedAlgTyCon tc = all is_triv_lpat (hsConPatArgs ps) is_flat_prod_pat _ = False
GHC/IfaceToCore.hs view
@@ -1743,7 +1743,7 @@ core_expr' <- tcIfaceExpr expr -- Check for type consistency in the unfolding- -- See Note [Linting Unfoldings from Interfaces]+ -- See Note [Linting Unfoldings from Interfaces] in GHC.Core.Lint when (isTopLevel toplvl) $ whenGOptM Opt_DoCoreLinting $ do in_scope <- get_in_scope
GHC/Parser/PostProcess.hs view
@@ -1,12 +1,12 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
GHC/Rename/Env.hs view
@@ -1,6 +1,4 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeApplications #-}
GHC/Rename/Utils.hs view
@@ -549,12 +549,15 @@ -- imported from ‘Prelude’ at T15487.hs:1:8-13 -- or ... -- See #15487- pp_greMangledName gre@(GRE { gre_name = child+ pp_greMangledName gre@(GRE { gre_name = child, gre_par = par , gre_lcl = lcl, gre_imp = iss }) = case child of- FieldGreName fl -> text "the field" <+> quotes (ppr fl)+ FieldGreName fl -> text "the field" <+> quotes (ppr fl) <+> parent_info NormalGreName name -> quotes (pp_qual name <> dot <> ppr (nameOccName name)) where+ parent_info = case par of+ NoParent -> empty+ ParentIs { par_is = par_name } -> text "of record" <+> quotes (ppr par_name) pp_qual name | lcl = ppr (nameModule name)
GHC/Runtime/Eval.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
GHC/Runtime/Interpreter.hs view
@@ -1,5 +1,7 @@-{-# LANGUAGE RecordWildCards, ScopedTypeVariables, BangPatterns, CPP #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} -- | Interacting with the iserv interpreter, whether it is running on an
GHC/Settings/Config.hs view
@@ -22,7 +22,7 @@ cProjectName = "The Glorious Glasgow Haskell Compilation System" cBooterVersion :: String-cBooterVersion = "8.10.7"+cBooterVersion = "9.2.3" cStage :: String cStage = show (2 :: Int)
GHC/Stg/Unarise.hs view
@@ -162,6 +162,18 @@ layout to use. Note that unlifted values can't be let-bound, so we don't need types in StgRhsCon. +Note [UnariseEnv]+~~~~~~~~~~~~~~~~~~+At any variable occurrence 'v',+* If the UnariseEnv has a binding for 'v', the binding says what 'v' is bound to+* If not, 'v' stands just for itself.++Most variables are unaffected by unarisation, and (for efficiency) we don't put+them in the UnariseEnv at all. But NB: when we go under a binding for 'v' we must+remember to delete 'v' from the UnariseEnv, lest occurrences of 'v' see the outer+binding for the variable (#21396).++ Note [UnariseEnv can map to literals] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ To avoid redundant case expressions when unarising unboxed sums, UnariseEnv@@ -277,6 +289,8 @@ ppr (UnaryVal arg) = text "UnaryVal" <+> ppr arg -- | Extend the environment, checking the UnariseEnv invariant.+-- The id is mapped to one or more things.+-- See Note [UnariseEnv] extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv extendRho rho x (MultiVal args) = ASSERT(all (isNvUnaryType . stgArgType) args)@@ -284,7 +298,15 @@ extendRho rho x (UnaryVal val) = ASSERT(isNvUnaryType (stgArgType val)) extendVarEnv rho x (UnaryVal val)+-- Properly shadow things from an outer scope.+-- See Note [UnariseEnv] +-- The id stands for itself so we don't record a mapping.+-- See Note [UnariseEnv]+extendRhoWithoutValue :: UnariseEnv -> Id -> UnariseEnv+extendRhoWithoutValue rho x = delVarEnv rho x++ -------------------------------------------------------------------------------- unarise :: UniqSupply -> [StgTopBinding] -> [StgTopBinding]@@ -693,7 +715,7 @@ -> do x' <- mkId (mkFastString "us") (primRepToType rep) return (extendRho rho x (MultiVal [StgVarArg x']), [x']) | otherwise- -> return (rho, [x])+ -> return (extendRhoWithoutValue rho x, [x]) reps -> do xs <- mkIds (mkFastString "us") (map primRepToType reps)
GHC/StgToCmm/DataCon.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE TupleSections #-} {-# LANGUAGE CPP #-} -----------------------------------------------------------------------------
GHC/StgToCmm/Monad.hs view
@@ -1,9 +1,7 @@-{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternSynonyms #-}- ----------------------------------------------------------------------------- --
GHC/StgToCmm/Prim.hs view
@@ -1712,6 +1712,8 @@ -> PrimopCmmEmit opTranslate64 args mkMop callish = case platformWordSize platform of+ -- LLVM and C `can handle larger than native size arithmetic natively.+ _ | not ncg -> opTranslate args $ mkMop W64 PW4 -> opCallish args callish PW8 -> opTranslate args $ mkMop W64 #endif
GHC/Tc/Errors.hs view
@@ -1046,11 +1046,11 @@ pprArising :: CtOrigin -> SDoc -- Used for the main, top-level error message--- We've done special processing for TypeEq, KindEq, Given-pprArising (TypeEqOrigin {}) = empty-pprArising (KindEqOrigin {}) = empty-pprArising (GivenOrigin {}) = empty-pprArising orig = pprCtOrigin orig+-- We've done special processing for TypeEq, KindEq, givens+pprArising (TypeEqOrigin {}) = empty+pprArising (KindEqOrigin {}) = empty+pprArising orig | isGivenOrigin orig = empty+ | otherwise = pprCtOrigin orig -- Add the "arising from..." part to a message about bunch of dicts addArising :: CtOrigin -> SDoc -> SDoc
GHC/Tc/Gen/Bind.hs view
@@ -451,9 +451,9 @@ -> LHsBind GhcRn -> IsGroupClosed -> TcM thing -> TcM (LHsBinds GhcTc, thing) tc_single _top_lvl sig_fn prag_fn- (L _ (PatSynBind _ psb@PSB{ psb_id = L _ name }))+ (L loc (PatSynBind _ psb)) _ thing_inside- = do { (aux_binds, tcg_env) <- tcPatSynDecl psb (sig_fn name) prag_fn+ = do { (aux_binds, tcg_env) <- tcPatSynDecl (L loc psb) sig_fn prag_fn ; thing <- setGblEnv tcg_env thing_inside ; return (aux_binds, thing) }
GHC/Tc/Gen/Sig.hs view
@@ -20,7 +20,8 @@ tcInstSig, TcPragEnv, emptyPragEnv, lookupPragEnv, extendPragEnv,- mkPragEnv, tcSpecPrags, tcSpecWrapper, tcImpPrags, addInlinePrags+ mkPragEnv, tcSpecPrags, tcSpecWrapper, tcImpPrags,+ addInlinePrags, addInlinePragArity ) where #include "HsVersions.h"@@ -47,7 +48,6 @@ import GHC.Driver.Session import GHC.Driver.Backend-import GHC.Driver.Ppr import GHC.Types.Var ( TyVar, Specificity(..), tyVarKind, binderVars ) import GHC.Types.Id ( Id, idName, idType, setInlinePragma , mkLocalId, realIdUnfolding )@@ -545,29 +545,32 @@ prs = mapMaybe get_sig sigs get_sig :: LSig GhcRn -> Maybe (Name, LSig GhcRn)- get_sig (L l (SpecSig x lnm@(L _ nm) ty inl))- = Just (nm, L l $ SpecSig x lnm ty (add_arity nm inl))- get_sig (L l (InlineSig x lnm@(L _ nm) inl))- = Just (nm, L l $ InlineSig x lnm (add_arity nm inl))- get_sig (L l (SCCFunSig x st lnm@(L _ nm) str))- = Just (nm, L l $ SCCFunSig x st lnm str)+ get_sig sig@(L _ (SpecSig _ (L _ nm) _ _)) = Just (nm, add_arity nm sig)+ get_sig sig@(L _ (InlineSig _ (L _ nm) _)) = Just (nm, add_arity nm sig)+ get_sig sig@(L _ (SCCFunSig _ _ (L _ nm) _)) = Just (nm, sig) get_sig _ = Nothing - add_arity n inl_prag -- Adjust inl_sat field to match visible arity of function- | Inline <- inl_inline inl_prag- -- add arity only for real INLINE pragmas, not INLINABLE+ add_arity n sig -- Adjust inl_sat field to match visible arity of function = case lookupNameEnv ar_env n of- Just ar -> inl_prag { inl_sat = Just ar }- Nothing -> WARN( True, text "mkPragEnv no arity" <+> ppr n )- -- There really should be a binding for every INLINE pragma- inl_prag- | otherwise- = inl_prag+ Just ar -> addInlinePragArity ar sig+ Nothing -> sig -- See Note [Pattern synonym inline arity] -- ar_env maps a local to the arity of its definition ar_env :: NameEnv Arity ar_env = foldr lhsBindArity emptyNameEnv binds +addInlinePragArity :: Arity -> LSig GhcRn -> LSig GhcRn+addInlinePragArity ar (L l (InlineSig x nm inl)) = L l (InlineSig x nm (add_inl_arity ar inl))+addInlinePragArity ar (L l (SpecSig x nm ty inl)) = L l (SpecSig x nm ty (add_inl_arity ar inl))+addInlinePragArity _ sig = sig++add_inl_arity :: Arity -> InlinePragma -> InlinePragma+add_inl_arity ar prag@(InlinePragma { inl_inline = inl_spec })+ | Inline {} <- inl_spec -- Add arity only for real INLINE pragmas, not INLINABLE+ = prag { inl_sat = Just ar }+ | otherwise+ = prag+ lhsBindArity :: LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env = extendNameEnv env (unLoc id) (matchGroupArity ms)@@ -602,6 +605,25 @@ : map pp_inl (inl1:inl2:inls)))) pp_inl (L loc prag) = ppr prag <+> parens (ppr loc)+++{- Note [Pattern synonym inline arity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+ {-# INLINE P #-}+ pattern P x = (x, True)++The INLINE pragma attaches to both the /matcher/ and the /builder/ for+the pattern synonym; see Note [Pragmas for pattern synonyms] in+GHC.Tc.TyCl.PatSyn. But they have different inline arities (i.e. number+of binders to which we apply the function before inlining), and we don't+know what those arities are yet. So for pattern synonyms we don't set+the inl_sat field yet; instead we do so (via addInlinePragArity) in+GHC.Tc.TyCl.PatSyn.tcPatSynMatcher and tcPatSynBuilderBind.++It's a bit messy that we set the arities in different ways. Perhaps we+should add the arity later for all binders. But it works fine like this.+-} {- *********************************************************************
GHC/Tc/Instance/Typeable.hs view
@@ -4,10 +4,9 @@ -} {-# LANGUAGE CPP #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE MultiWayIf #-} module GHC.Tc.Instance.Typeable(mkTypeableBinds, tyConIsTypeable) where
GHC/Tc/Module.hs view
@@ -2567,14 +2567,12 @@ mkPhiTy (map idType dicts) res_ty } ; ty <- zonkTcType all_expr_ty ; - -- We normalise type families, so that the type of an expression is the- -- same as of a bound expression (GHC.Tc.Gen.Bind.mkInferredPolyId). See Trac- -- #10321 for further discussion.+ -- See Note [Normalising the type in :type] fam_envs <- tcGetFamInstEnvs ;- -- normaliseType returns a coercion which we discard, so the Role is- -- irrelevant- return (snd (normaliseType fam_envs Nominal ty))- }+ let { normalised_type = snd $ normaliseType fam_envs Nominal ty+ -- normaliseType returns a coercion which we discard, so the Role is irrelevant.+ ; final_type = if isSigmaTy res_ty then ty else normalised_type } ;+ return final_type } where -- Optionally instantiate the type of the expression -- See Note [TcRnExprMode]@@ -2599,6 +2597,31 @@ Solution: use tcInferSigma, which in turn uses tcInferApp, which has a special case for application chains.++Note [Normalising the type in :type]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In :t <expr> we usually normalise the type (to simplify type functions)+before displaying the result. Reason (see #10321): otherwise we may show+types like+ <expr> :: Vec (1+2) Int+rather than the simpler+ <expr> :: Vec 3 Int+In GHC.Tc.Gen.Bind.mkInferredPolyId we normalise for a very similar reason.++However this normalisation is less helpful when <expr> is just+an identifier, whose user-written type happens to contain type-function+applications. E.g. (#20974)+ test :: F [Monad, A, B] m => m ()+where F is a type family. If we say `:t test`, we'd prefer to see+the type family un-expanded.++We adopt the following ad-hoc solution: if the type inferred for <expr>+(before generalisation, namely res_ty) is a SigmaType (i.e. is not+fully instantiated) then do not normalise; otherwise normalise.+This is not ideal; for example, suppose x :: F Int. Then+ :t x+would be normalised because `F Int` is not a SigmaType. But+anything here is ad-hoc, and it's a user-sought improvement. -} --------------------------
GHC/Tc/Solver.hs view
@@ -2056,19 +2056,28 @@ ; bad_telescope <- checkBadTelescope implic - ; let dead_givens | warnRedundantGivens info- = filterOut (`elemVarSet` need_inner) givens- | otherwise = [] -- None to report+ ; let (used_givens, unused_givens)+ | warnRedundantGivens info+ = partition (`elemVarSet` need_inner) givens+ | otherwise = (givens, []) -- None to report + minimal_used_givens = mkMinimalBySCs evVarPred used_givens+ is_minimal = (`elemVarSet` mkVarSet minimal_used_givens)++ warn_givens+ | not (null unused_givens) = unused_givens+ | warnRedundantGivens info = filterOut is_minimal used_givens+ | otherwise = []+ discard_entire_implication -- Can we discard the entire implication?- = null dead_givens -- No warning from this implication+ = null warn_givens -- No warning from this implication && not bad_telescope && isEmptyWC pruned_wc -- No live children && isEmptyVarSet need_outer -- No needed vars to pass up to parent final_status | bad_telescope = IC_BadTelescope- | otherwise = IC_Solved { ics_dead = dead_givens }+ | otherwise = IC_Solved { ics_dead = warn_givens } final_implic = implic { ic_status = final_status , ic_wanted = pruned_wc } @@ -2299,37 +2308,37 @@ With Opt_WarnRedundantConstraints, GHC can report which constraints of a type signature (or instance declaration) are redundant, and can be omitted. Here is an overview of how it-works:+works. +This is all tested in typecheck/should_compile/T20602 (among+others).+ ----- What is a redundant constraint? * The things that can be redundant are precisely the Given constraints of an implication. * A constraint can be redundant in two different ways:- a) It is implied by other givens. E.g.- f :: (Eq a, Ord a) => blah -- Eq a unnecessary- g :: (Eq a, a~b, Eq b) => blah -- Either Eq a or Eq b unnecessary- b) It is not needed by the Wanted constraints covered by the+ a) It is not needed by the Wanted constraints covered by the implication E.g. f :: Eq a => a -> Bool f x = True -- Equality not used+ b) It is implied by other givens. E.g.+ f :: (Eq a, Ord a) => blah -- Eq a unnecessary+ g :: (Eq a, a~b, Eq b) => blah -- Either Eq a or Eq b unnecessary -* To find (a), when we have two Given constraints,- we must be careful to drop the one that is a naked variable (if poss).- So if we have- f :: (Eq a, Ord a) => blah- then we may find [G] sc_sel (d1::Ord a) :: Eq a- [G] d2 :: Eq a- We want to discard d2 in favour of the superclass selection from- the Ord dictionary. This is done by GHC.Tc.Solver.Interact.solveOneFromTheOther- See Note [Replacement vs keeping].+* To find (a) we need to know which evidence bindings are 'wanted';+ hence the eb_is_given field on an EvBind. -* To find (b) we need to know which evidence bindings are 'wanted';- hence the eb_is_given field on an EvBind.+* To find (b), we use mkMinimalBySCs on the Givens to see if any+ are unnecessary. ----- How tracking works +* When two Givens are the same, we drop the evidence for the one+ that requires more superclass selectors. This is done+ according to Note [Replacement vs keeping] in GHC.Tc.Solver.Interact.+ * The ic_need fields of an Implic records in-scope (given) evidence variables bound by the context, that were needed to solve this implication (so far). See the declaration of Implication.@@ -2343,9 +2352,15 @@ * We compute which evidence variables are needed by an implication in setImplicationStatus. A variable is needed if a) it is free in the RHS of a Wanted EvBind,- b) it is free in the RHS of an EvBind whose LHS is needed,+ b) it is free in the RHS of an EvBind whose LHS is needed, or c) it is in the ics_need of a nested implication. +* After computing which variables are needed, we then look at the+ remaining variables for internal redundancies. This is case (b)+ from above. This is also done in setImplicationStatus.+ Note that we only look for case (b) if case (a) shows up empty,+ as exemplified below.+ * We need to be careful not to discard an implication prematurely, even one that is fully solved, because we might thereby forget which variables it needs, and hence wrongly@@ -2354,6 +2369,32 @@ simply has no free vars. This careful discarding is also handled in setImplicationStatus. +* Examples:++ f, g, h :: (Eq a, Ord a) => a -> Bool+ f x = x == x+ g x = x > x+ h x = x == x && x > x++ All three will discover that they have two [G] Eq a constraints:+ one as given and one extracted from the Ord a constraint. They will+ both discard the latter, as noted above and in+ Note [Replacement vs keeping] in GHC.Tc.Solver.Interact.++ The body of f uses the [G] Eq a, but not the [G] Ord a. It will+ report a redundant Ord a using the logic for case (a).++ The body of g uses the [G] Ord a, but not the [G] Eq a. It will+ report a redundant Eq a using the logic for case (a).++ The body of h uses both [G] Ord a and [G] Eq a. Case (a) will+ thus come up with nothing redundant. But then, the case (b)+ check will discover that Eq a is redundant and report this.++ If we did case (b) even when case (a) reports something, then+ we would report both constraints as redundant for f, which is+ terrible.+ ----- Reporting redundant constraints * GHC.Tc.Errors does the actual warning, in warnRedundantConstraints.@@ -2384,13 +2425,18 @@ ----- Shortcomings -Consider (see #9939)- f2 :: (Eq a, Ord a) => a -> a -> Bool- -- Ord a redundant, but Eq a is reported- f2 x y = (x == y)+Consider -We report (Eq a) as redundant, whereas actually (Ord a) is. But it's-really not easy to detect that!+ j :: (Eq a, a ~ b) => a -> Bool+ j x = x == x++ k :: (Eq a, b ~ a) => a -> Bool+ k x = x == x++Currently (Nov 2021), j issues no warning, while k says that b ~ a+is redundant. This is because j uses the a ~ b constraint to rewrite+everything to be in terms of b, while k does none of that. This is+ridiculous, but I (Richard E) don't see a good fix. -}
GHC/Tc/Solver/Canonical.hs view
@@ -569,17 +569,24 @@ -- get down to a base predicate, we'll include its size. -- #10335 - | GivenOrigin skol_info <- ctLocOrigin loc -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance- -- for explantation of this transformation for givens- = case skol_info of- InstSkol -> loc { ctl_origin = GivenOrigin (InstSC size) }- InstSC n -> loc { ctl_origin = GivenOrigin (InstSC (n `max` size)) }- _ -> loc+ -- for explantation of InstSCOrigin and Note [Replacement vs keeping] in+ -- GHC.Tc.Solver.Interact for why we need OtherSCOrigin and depths+ | otherwise+ = loc { ctl_origin = new_orig }+ where+ new_orig = case ctLocOrigin loc of+ -- these cases are when we have something that's already a superclass constraint+ InstSCOrigin sc_depth n -> InstSCOrigin (sc_depth + 1) (n `max` size)+ OtherSCOrigin sc_depth si -> OtherSCOrigin (sc_depth + 1) si - | otherwise -- Probably doesn't happen, since this function- = loc -- is only used for Givens, but does no harm+ -- these cases do not already have a superclass constraint: depth starts at 1+ GivenOrigin InstSkol -> InstSCOrigin 1 size+ GivenOrigin other_skol -> OtherSCOrigin 1 other_skol + other_orig -> pprPanic "Given constraint without given origin" $+ ppr evar $$ ppr other_orig+ mk_strict_superclasses rec_clss ev tvs theta cls tys | all noFreeVarsOfType tys = return [] -- Wanteds with no variables yield no deriveds.@@ -2322,7 +2329,6 @@ -- type families are OK here -- NB: no occCheckExpand here; see Note [Rewriting synonyms] in GHC.Tc.Solver.Rewrite - -- a ~R# b a is soluble if b later turns out to be Identity result = case eq_rel of NomEq -> result0@@ -2338,27 +2344,27 @@ ; continueWith (CEqCan { cc_ev = new_ev, cc_lhs = lhs , cc_rhs = rhs, cc_eq_rel = eq_rel }) } - else do { m_stuff <- breakTyVarCycle_maybe ev result lhs rhs- -- See Note [Type variable cycles];+ else do { m_stuff <- breakTyEqCycle_maybe ev result lhs rhs+ -- See Note [Type equality cycles]; -- returning Nothing is the vastly common case ; case m_stuff of { Nothing -> do { traceTcS "canEqCanLHSFinish can't make a canonical" (ppr lhs $$ ppr rhs) ; continueWith (mkIrredCt reason new_ev) }- ; Just (lhs_tv, co, new_rhs) ->+ ; Just (co, new_rhs) -> do { traceTcS "canEqCanLHSFinish breaking a cycle" $ ppr lhs $$ ppr rhs ; traceTcS "new RHS:" (ppr new_rhs) -- This check is Detail (1) in the Note- ; if cterHasOccursCheck (checkTyVarEq dflags lhs_tv new_rhs)+ ; if cterHasOccursCheck (checkTypeEq dflags lhs new_rhs) - then do { traceTcS "Note [Type variable cycles] Detail (1)"+ then do { traceTcS "Note [Type equality cycles] Detail (1)" (ppr new_rhs) ; continueWith (mkIrredCt reason new_ev) } - else do { -- See Detail (6) of Note [Type variable cycles]+ else do { -- See Detail (6) of Note [Type equality cycles] new_new_ev <- rewriteEqEvidence new_ev NotSwapped lhs_ty new_rhs (mkTcNomReflCo lhs_ty) co@@ -2580,7 +2586,7 @@ good error messages we want to leave type synonyms unexpanded as much as possible. Hence the ps_xi1, ps_xi2 argument passed to canEqCanLHS. -Note [Type variable cycles]+Note [Type equality cycles] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this situation (from indexed-types/should_compile/GivenLoop): @@ -2594,14 +2600,20 @@ *[WD] alpha ~ (Arg alpha -> Res alpha) [W] C alpha +or (typecheck/should_compile/T21515):++ type family Code a+ *[G] Code a ~ '[ '[ Head (Head (Code a)) ] ]+ [W] Code a ~ '[ '[ alpha ] ]+ In order to solve the final Wanted, we must use the starred constraint-for rewriting. But note that both starred constraints have occurs-check failures,+for rewriting. But note that all starred constraints have occurs-check failures, and so we can't straightforwardly add these to the inert set and use them for rewriting. (NB: A rigid type constructor is at the-top of both RHSs. If the type family were at the top, we'd just reorient-in canEqTyVarFunEq.)+top of all RHSs, preventing reorienting in canEqTyVarFunEq in the tyvar+cases.) -The key idea is to replace the type family applications in the RHS of the+The key idea is to replace the outermost type family applications in the RHS of the starred constraints with a fresh variable, which we'll call a cycle-breaker variable, or cbv. Then, relate the cbv back with the original type family application via new equality constraints. Our situations thus become:@@ -2619,8 +2631,14 @@ [WD] Res alpha ~ cbv2 [W] C alpha +or++ [G] Code a ~ '[ '[ cbv ] ]+ [G] Head (Head (Code a)) ~ cbv+ [W] Code a ~ '[ '[ alpha ] ]+ This transformation (creating the new types and emitting new equality-constraints) is done in breakTyVarCycle_maybe.+constraints) is done in breakTyEqCycle_maybe. The details depend on whether we're working with a Given or a Derived. (Note that the Wanteds are really WDs, above. This is because Wanteds@@ -2643,30 +2661,30 @@ So we fill in the metavariables with their original type family applications after we're done running the solver (in nestImplicTcS and runTcSWithEvBinds). This is done by restoreTyVarCycles, which uses the inert_cycle_breakers field in-InertSet, which contains the pairings invented in breakTyVarCycle_maybe.+InertSet, which contains the pairings invented in breakTyEqCycle_maybe. That is: We transform- [G] g : a ~ ...(F a)...+ [G] g : lhs ~ ...(F lhs)... to- [G] (Refl a) : F a ~ cbv -- CEqCan- [G] g : a ~ ...cbv... -- CEqCan+ [G] (Refl lhs) : F lhs ~ cbv -- CEqCan+ [G] g : lhs ~ ...cbv... -- CEqCan Note that * `cbv` is a fresh cycle breaker variable. * `cbv` is a is a meta-tyvar, but it is completely untouchable. * We track the cycle-breaker variables in inert_cycle_breakers in InertSet-* We eventually fill in the cycle-breakers, with `cbv := F a`.+* We eventually fill in the cycle-breakers, with `cbv := F lhs`. No one else fills in cycle-breakers!-* In inert_cycle_breakers, we remember the (cbv, F a) pair; that is, we- remember the /original/ type. The [G] F a ~ cbv constraint may be rewritten- by other givens (eg if we have another [G] a ~ (b,c), but at the end we- still fill in with cbv := F a+* The evidence for the new `F lhs ~ cbv` constraint is Refl, because we know+ this fill-in is ultimately going to happen.+* In inert_cycle_breakers, we remember the (cbv, F lhs) pair; that is, we+ remember the /original/ type. The [G] F lhs ~ cbv constraint may be rewritten+ by other givens (eg if we have another [G] lhs ~ (b,c)), but at the end we+ still fill in with cbv := F lhs * This fill-in is done when solving is complete, by restoreTyVarCycles in nestImplicTcS and runTcSWithEvBinds.-* The evidence for the new `F a ~ cbv` constraint is Refl, because we know this fill-in is- ultimately going to happen. Wanted/Derived --------------@@ -2684,12 +2702,18 @@ where cbv1 and cbv2 are fresh TauTvs. Why TauTvs? See [Why TauTvs] below. -Critically, we emit the constraint directly instead of calling unifyWanted.+Critically, we emit the two new constraints (the last two above)+directly instead of calling unifyWanted. (Otherwise, we'd end up unifying cbv1+and cbv2 immediately, achieving nothing.) Next, we unify alpha := cbv1 -> cbv2, having eliminated the occurs check. This-unification happens in the course of normal behavior of top-level+unification -- which must be the next step after breaking the cycles --+happens in the course of normal behavior of top-level interactions, later in the solver pipeline. We know this unification will-indeed happen, because breakTyVarCycle_maybe, which decides whether to apply-this logic, goes to pains to make sure unification will succeed. Now, we're+indeed happen because breakTyEqCycle_maybe, which decides whether to apply+this logic, checks to ensure unification will succeed in its final_check.+(In particular, the LHS must be a touchable tyvar, never a type family. We don't+yet have an example of where this logic is needed with a type family, and it's+unclear how to handle this case, so we're skipping for now.) Now, we're here (including further context from our original example, from the top of the Note): @@ -2764,8 +2788,9 @@ ------------ We detect this scenario by the following characteristics:- - a constraint with a tyvar on its LHS- - with a soluble occurs-check failure+ - a constraint with a soluble occurs-check failure+ (as indicated by the cteSolubleOccurs bit set in a CheckTyEqResult+ from checkTypeEq) - and a nominal equality - and either - a Given flavour (but see also Detail (7) below)@@ -2791,29 +2816,31 @@ (1) We don't look under foralls, at all, when substituting away type family applications, because doing so can never be fruitful. Recall that we- are in a case like [G] a ~ forall b. ... a .... Until we have a type- family that can pull the body out from a forall, this will always be+ are in a case like [G] lhs ~ forall b. ... lhs .... Until we have a type+ family that can pull the body out from a forall (e.g. type instance F (forall b. ty) = ty),+ this will always be insoluble. Note also that the forall cannot be in an argument to a type family, or that outer type family application would already have been substituted away. - However, we still must check to make sure that breakTyVarCycle_maybe actually- succeeds in getting rid of all occurrences of the offending variable. If+ However, we still must check to make sure that breakTyEqCycle_maybe actually+ succeeds in getting rid of all occurrences of the offending lhs. If one is hidden under a forall, this won't be true. A similar problem can happen if the variable appears only in a kind (e.g. k ~ ... (a :: k) ...). So we perform an additional check after- performing the substitution. It is tiresome to re-run all of checkTyVarEq+ performing the substitution. It is tiresome to re-run all of checkTypeEq here, but reimplementing just the occurs-check is even more tiresome. Skipping this check causes typecheck/should_fail/GivenForallLoop and polykinds/T18451 to loop. (2) Our goal here is to avoid loops in rewriting. We can thus skip looking- in coercions, as we don't rewrite in coercions. (This is another reason+ in coercions, as we don't rewrite in coercions in the algorithm in+ GHC.Solver.Rewrite. (This is another reason we need to re-check that we've gotten rid of all occurrences of the offending variable.) - (3) As we're substituting, we can build ill-kinded+ (3) As we're substituting as described in this Note, we can build ill-kinded types. For example, if we have Proxy (F a) b, where (b :: F a), then replacing this with Proxy cbv b is ill-kinded. However, we will later set cbv := F a, and so the zonked type will be well-kinded again.@@ -2833,9 +2860,13 @@ we will eventually set the cycle-breaker variable to be the type family, and then, after the zonk, all will be well. - (5) The approach here is inefficient. For instance, we could choose to- affect only type family applications that mention the offending variable:- in a ~ (F b, G a), we need to replace only G a, not F b. Furthermore,+ (5) The approach here is inefficient because it replaces every (outermost)+ type family application with a type variable, regardless of whether that+ particular appplication is implicated in the occurs check. An alternative+ would be to replce only type-family applications that meantion the offending LHS.+ For instance, we could choose to+ affect only type family applications that mention the offending LHS:+ e.g. in a ~ (F b, G a), we need to replace only G a, not F b. Furthermore, we could try to detect cases like a ~ (F a, F a) and use the same tyvar to replace F a. (Cf. Note [Flattening type-family applications when matching instances]@@ -2846,9 +2877,10 @@ performant solution seems unworthwhile. (6) We often get the predicate associated with a constraint from its- evidence. We thus must not only make sure the generated CEqCan's- fields have the updated RHS type, but we must also update the- evidence itself. This is done by the call to rewriteEqEvidence+ evidence with ctPred. We thus must not only make sure the generated+ CEqCan's fields have the updated RHS type (that is, the one produced+ by replacing type family applications with fresh variables),+ but we must also update the evidence itself. This is done by the call to rewriteEqEvidence in canEqCanLHSFinish. (7) We don't wish to apply this magic on the equalities created@@ -2888,12 +2920,12 @@ occurs-check bit set (only). We track these equalities by giving them a special CtOrigin,- CycleBreakerOrigin. This works for both Givens and WDs, as- we need the logic in the WD case for e.g. typecheck/should_fail/T17139.+ CycleBreakerOrigin. This works for both Givens and Wanteds, as+ we need the logic in the W case for e.g. typecheck/should_fail/T17139. (8) We really want to do this all only when there is a soluble occurs-check failure, not when other problems arise (such as an impredicative- equality like alpha ~ forall a. a -> a). That is why breakTyVarCycle_maybe+ equality like alpha ~ forall a. a -> a). That is why breakTyEqCycle_maybe uses cterHasOnlyProblem when looking at the result of checkTypeEq, which checks for many of the invariants on a CEqCan. -}
GHC/Tc/Solver/Interact.hs view
@@ -49,7 +49,6 @@ import GHC.Types.Var.Env import Control.Monad-import GHC.Data.Maybe( isJust ) import GHC.Data.Pair (Pair(..)) import GHC.Types.Unique( hasKey ) import GHC.Driver.Session@@ -491,7 +490,7 @@ -- After this, neither ev_i or ev_w are Derived | CtWanted { ctev_loc = loc_w } <- ev_w- , prohibitedSuperClassSolve (ctEvLoc ev_i) loc_w+ , prohibitedSuperClassSolve loc_i loc_w = -- inert must be Given do { traceTcS "prohibitedClassSolve1" (ppr ev_i $$ ppr ev_w) ; return KeepWork }@@ -525,9 +524,7 @@ -- See Note [Replacement vs keeping] | lvl_i == lvl_w- = do { ev_binds_var <- getTcEvBindsVar- ; binds <- getTcEvBindsMap ev_binds_var- ; return (same_level_strategy binds) }+ = return same_level_strategy | otherwise -- Both are Given, levels differ = return different_level_strategy@@ -537,42 +534,44 @@ loc_w = ctEvLoc ev_w lvl_i = ctLocLevel loc_i lvl_w = ctLocLevel loc_w- ev_id_i = ctEvEvId ev_i- ev_id_w = ctEvEvId ev_w different_level_strategy -- Both Given | isIPLikePred pred = if lvl_w > lvl_i then KeepWork else KeepInert | otherwise = if lvl_w > lvl_i then KeepInert else KeepWork- -- See Note [Replacement vs keeping] (the different-level bullet)+ -- See Note [Replacement vs keeping] part (1) -- For the isIPLikePred case see Note [Shadowing of Implicit Parameters] - same_level_strategy binds -- Both Given- | GivenOrigin (InstSC s_i) <- ctLocOrigin loc_i- = case ctLocOrigin loc_w of- GivenOrigin (InstSC s_w) | s_w < s_i -> KeepWork- | otherwise -> KeepInert- _ -> KeepWork+ same_level_strategy -- Both Given+ = case (ctLocOrigin loc_i, ctLocOrigin loc_w) of+ -- case 2(a) from Note [Replacement vs keeping]+ (InstSCOrigin _depth_i size_i, InstSCOrigin _depth_w size_w)+ | size_w < size_i -> KeepWork+ | otherwise -> KeepInert - | GivenOrigin (InstSC {}) <- ctLocOrigin loc_w- = KeepInert+ -- case 2(c) from Note [Replacement vs keeping]+ (InstSCOrigin depth_i _, OtherSCOrigin depth_w _) -> choose_shallower depth_i depth_w+ (OtherSCOrigin depth_i _, InstSCOrigin depth_w _) -> choose_shallower depth_i depth_w+ (OtherSCOrigin depth_i _, OtherSCOrigin depth_w _) -> choose_shallower depth_i depth_w - | has_binding binds ev_id_w- , not (has_binding binds ev_id_i)- , not (ev_id_i `elemVarSet` findNeededEvVars binds (unitVarSet ev_id_w))- = KeepWork+ -- case 2(b) from Note [Replacement vs keeping]+ (InstSCOrigin {}, _) -> KeepWork+ (OtherSCOrigin {}, _) -> KeepWork - | otherwise- = KeepInert+ -- case 2(d) from Note [Replacement vs keeping]+ _ -> KeepInert - has_binding binds ev_id = isJust (lookupEvBind binds ev_id)+ choose_shallower depth_i depth_w | depth_w < depth_i = KeepWork+ | otherwise = KeepInert+ -- favor KeepInert in the equals case, according to 2(d) from the Note {- Note [Replacement vs keeping] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we have two Given constraints both of type (C tys), say, which should-we keep? More subtle than you might think!+we keep? More subtle than you might think! This is all implemented in+solveOneFromTheOther. - * Constraints come from different levels (different_level_strategy)+ 1) Constraints come from different levels (different_level_strategy) - For implicit parameters we want to keep the innermost (deepest) one, so that it overrides the outer one.@@ -587,38 +586,36 @@ 8% performance improvement in nofib cryptarithm2, compared to just rolling the dice. I didn't investigate why. - * Constraints coming from the same level (i.e. same implication)+ 2) Constraints coming from the same level (i.e. same implication) - (a) Always get rid of InstSC ones if possible, since they are less- useful for solving. If both are InstSC, choose the one with- the smallest TypeSize- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance+ (a) If both are InstSCOrigin, choose the one with the smallest TypeSize,+ according to Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance. - (b) Keep the one that has a non-trivial evidence binding.- Example: f :: (Eq a, Ord a) => blah- then we may find [G] d3 :: Eq a- [G] d2 :: Eq a- with bindings d3 = sc_sel (d1::Ord a)- We want to discard d2 in favour of the superclass selection from- the Ord dictionary.- Why? See Note [Tracking redundant constraints] in GHC.Tc.Solver again.+ (b) Prefer constraints that are not superclass selections. Example: - (c) But don't do (b) if the evidence binding depends transitively on the- one without a binding. Example (with RecursiveSuperClasses)- class C a => D a- class D a => C a- Inert: d1 :: C a, d2 :: D a- Binds: d3 = sc_sel d2, d2 = sc_sel d1- Work item: d3 :: C a- Then it'd be ridiculous to replace d1 with d3 in the inert set!- Hence the findNeedEvVars test. See #14774.+ f :: (Eq a, Ord a) => a -> Bool+ f x = x == x - * Finally, when there is still a choice, use KeepInert rather than- KeepWork, for two reasons:- - to avoid unnecessary munging of the inert set.- - to cut off superclass loops; see Note [Superclass loops] in GHC.Tc.Solver.Canonical+ Eager superclass expansion gives us two [G] Eq a constraints. We+ want to keep the one from the user-written Eq a, not the superclass+ selection. This means we report the Ord a as redundant with+ -Wredundant-constraints, not the Eq a. -Doing the depth-check for implicit parameters, rather than making the work item+ Getting this wrong was #20602. See also+ Note [Tracking redundant constraints] in GHC.Tc.Solver.++ (c) If both are superclass selections (but not both InstSCOrigin), choose the one+ with the shallower superclass-selection depth, in the hope of identifying+ more correct redundant constraints. This is really a generalization of+ point (b), because the superclass depth of a non-superclass+ constraint is 0.++ (d) Finally, when there is still a choice, use KeepInert rather than+ KeepWork, for two reasons:+ - to avoid unnecessary munging of the inert set.+ - to cut off superclass loops; see Note [Superclass loops] in GHC.Tc.Solver.Canonical++Doing the level-check for implicit parameters, rather than making the work item always override, is important. Consider data T a where { T1 :: (?x::Int) => T Int; T2 :: T a }@@ -634,7 +631,7 @@ - process a~Int, kicking out (?x::a) - process (?x::Int), the inner given, adding to inert set - process (?x::a), the outer given, overriding the inner given-Wrong! The depth-check ensures that the inner implicit parameter wins.+Wrong! The level-check ensures that the inner implicit parameter wins. (Actually I think that the order in which the work-list is processed means that this chain of events won't happen, but that's very fragile.) @@ -2362,35 +2359,57 @@ matchLocalInst pred loc = do { inerts@(IS { inert_cans = ics }) <- getTcSInerts ; case match_local_inst inerts (inert_insts ics) of- ([], False) -> do { traceTcS "No local instance for" (ppr pred)- ; return NoInstance }- ([(dfun_ev, inst_tys)], unifs)- | not unifs+ ([], Nothing) -> do { traceTcS "No local instance for" (ppr pred)+ ; return NoInstance }++ -- See Note [Use only the best local instance] about+ -- superclass depths+ (matches, unifs)+ | [(dfun_ev, inst_tys)] <- best_matches+ , maybe True (> min_sc_depth) unifs -> do { let dfun_id = ctEvEvId dfun_ev ; (tys, theta) <- instDFunType dfun_id inst_tys ; let result = OneInst { cir_new_theta = theta , cir_mk_ev = evDFunApp dfun_id tys , cir_what = LocalInstance }- ; traceTcS "Local inst found:" (ppr result)+ ; traceTcS "Best local inst found:" (ppr result)+ ; traceTcS "All local insts:" (ppr matches) ; return result }- _ -> do { traceTcS "Multiple local instances for" (ppr pred)- ; return NotSure }}++ | otherwise+ -> do { traceTcS "Multiple local instances for" (ppr pred)+ ; return NotSure }++ where+ extract_depth = sc_depth . ctEvLoc . fst+ min_sc_depth = minimum (map extract_depth matches)+ best_matches = filter ((== min_sc_depth) . extract_depth) matches } where pred_tv_set = tyCoVarsOfType pred + sc_depth :: CtLoc -> Int+ sc_depth ctloc = case ctLocOrigin ctloc of+ InstSCOrigin depth _ -> depth+ OtherSCOrigin depth _ -> depth+ _ -> 0++ -- See Note [Use only the best local instance] about superclass depths match_local_inst :: InertSet -> [QCInst] -> ( [(CtEvidence, [DFunInstType])]- , Bool ) -- True <=> Some unify but do not match+ , Maybe Int ) -- Nothing ==> no unifying local insts+ -- Just n ==> unifying local insts, with+ -- minimum superclass depth+ -- of n match_local_inst _inerts []- = ([], False)+ = ([], Nothing) match_local_inst inerts (qci@(QCI { qci_tvs = qtvs, qci_pred = qpred- , qci_ev = ev })+ , qci_ev = qev }) : qcis) | let in_scope = mkInScopeSet (qtv_set `unionVarSet` pred_tv_set) , Just tv_subst <- ruleMatchTyKiX qtv_set (mkRnEnv2 in_scope) emptyTvSubstEnv qpred pred- , let match = (ev, map (lookupVarEnv tv_subst) qtvs)+ , let match = (qev, map (lookupVarEnv tv_subst) qtvs) = (match:matches, unif) | otherwise@@ -2398,8 +2417,52 @@ , ppr qci $$ ppr pred ) -- ASSERT: unification relies on the -- quantified variables being fresh- (matches, unif || this_unif)+ (matches, unif `combine` this_unif) where+ qloc = ctEvLoc qev qtv_set = mkVarSet qtvs- this_unif = mightEqualLater inerts qpred (ctEvLoc ev) pred loc+ this_unif+ | mightEqualLater inerts qpred qloc pred loc = Just (sc_depth qloc)+ | otherwise = Nothing (matches, unif) = match_local_inst inerts qcis++ combine Nothing Nothing = Nothing+ combine (Just n) Nothing = Just n+ combine Nothing (Just n) = Just n+ combine (Just n1) (Just n2) = Just (n1 `min` n2)++{- Note [Use only the best local instance]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#20582) the ambiguity check for+ (forall a. Ord (m a), forall a. Semigroup a => Eq (m a)) => m Int++Because of eager expansion of given superclasses, we get+ [G] forall a. Ord (m a)+ [G] forall a. Eq (m a)+ [G] forall a. Semigroup a => Eq (m a)++ [W] forall a. Ord (m a)+ [W] forall a. Semigroup a => Eq (m a)++The first wanted is solved straightforwardly. But the second wanted+matches *two* local instances. Our general rule around multiple local+instances is that we refuse to commit to any of them. However, that+means that our type fails the ambiguity check. That's bad: the type+is perfectly fine. (This actually came up in the wild, in the streamly+library.)++The solution is to prefer local instances with fewer superclass selections.+So, matchLocalInst is careful to whittle down the matches only to the+ones with the shallowest superclass depth, and also to worry about unifying+local instances that are at that depth (or less).++By preferring these shallower local instances, we can use the last given+listed above and pass the ambiguity check.++The instance-depth mechanism uses the same superclass depth+information as described in Note [Replacement vs keeping], 2a.++Test case: typecheck/should_compile/T20582.++-}+
GHC/Tc/Solver/Monad.hs view
@@ -125,7 +125,7 @@ -- if the whole instance matcher simply belongs -- here - breakTyVarCycle_maybe, rewriterView+ breakTyEqCycle_maybe, rewriterView ) where #include "HsVersions.h"@@ -383,15 +383,20 @@ * * ********************************************************************* -} +type CycleBreakerVarStack = NonEmpty [(TcTyVar, TcType)]+ -- ^ a stack of (CycleBreakerTv, original family applications) lists+ -- first element in the stack corresponds to current implication;+ -- later elements correspond to outer implications+ -- used to undo the cycle-breaking needed to handle+ -- Note [Type equality cycles] in GHC.Tc.Solver.Canonical+ -- Why store the outer implications? For the use in mightEqualLater (only)+ data InertSet = IS { inert_cans :: InertCans -- Canonical Given, Wanted, Derived -- Sometimes called "the inert set" - , inert_cycle_breakers :: [(TcTyVar, TcType)]- -- a list of CycleBreakerTv / original family applications- -- used to undo the cycle-breaking needed to handle- -- Note [Type variable cycles in Givens] in GHC.Tc.Solver.Canonical+ , inert_cycle_breakers :: CycleBreakerVarStack , inert_famapp_cache :: FunEqMap (TcCoercion, TcType) -- Just a hash-cons cache for use when reducing family applications@@ -433,7 +438,7 @@ emptyInert :: InertSet emptyInert = IS { inert_cans = emptyInertCans- , inert_cycle_breakers = []+ , inert_cycle_breakers = [] :| [] , inert_famapp_cache = emptyFunEqs , inert_solved_dicts = emptyDictMap } @@ -2534,8 +2539,7 @@ mightEqualLater :: InertSet -> TcPredType -> CtLoc -> TcPredType -> CtLoc -> Bool -- See Note [What might equal later?] -- Used to implement logic in Note [Instance and Given overlap] in GHC.Tc.Solver.Interact-mightEqualLater (IS { inert_cycle_breakers = cbvs })- given_pred given_loc wanted_pred wanted_loc+mightEqualLater inert_set given_pred given_loc wanted_pred wanted_loc | prohibitedSuperClassSolve given_loc wanted_loc = False @@ -2581,10 +2585,8 @@ = case metaTyVarInfo tv of -- See Examples 8 and 9 in the Note CycleBreakerTv- | Just tyfam_app <- lookup tv cbvs- -> anyFreeVarsOfType mentions_meta_ty_var tyfam_app- | otherwise- -> pprPanic "mightEqualLater finds an unbound cbv" (ppr tv $$ ppr cbvs)+ -> anyFreeVarsOfType mentions_meta_ty_var+ (lookupCycleBreakerVar tv inert_set) _ -> True | otherwise = False@@ -2605,12 +2607,55 @@ prohibitedSuperClassSolve :: CtLoc -> CtLoc -> Bool -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance prohibitedSuperClassSolve from_loc solve_loc- | GivenOrigin (InstSC given_size) <- ctLocOrigin from_loc+ | InstSCOrigin _ given_size <- ctLocOrigin from_loc , ScOrigin wanted_size <- ctLocOrigin solve_loc = given_size >= wanted_size | otherwise = False +{- *********************************************************************+* *+ Cycle breakers+* *+********************************************************************* -}++-- | Return the type family application a CycleBreakerTv maps to.+lookupCycleBreakerVar :: TcTyVar -- ^ cbv, must be a CycleBreakerTv+ -> InertSet+ -> TcType -- ^ type family application the cbv maps to+lookupCycleBreakerVar cbv (IS { inert_cycle_breakers = cbvs_stack })+-- This function looks at every environment in the stack. This is necessary+-- to avoid #20231. This function (and its one usage site) is the only reason+-- that we store a stack instead of just the top environment.+ | Just tyfam_app <- ASSERT( (isCycleBreakerTyVar cbv) )+ firstJusts (NE.map (lookup cbv) cbvs_stack)+ = tyfam_app+ | otherwise+ = pprPanic "lookupCycleBreakerVar found an unbound cycle breaker" (ppr cbv $$ ppr cbvs_stack)++-- | Push a fresh environment onto the cycle-breaker var stack. Useful+-- when entering a nested implication.+pushCycleBreakerVarStack :: CycleBreakerVarStack -> CycleBreakerVarStack+pushCycleBreakerVarStack = ([] NE.<|)++-- | Add a new cycle-breaker binding to the top environment on the stack.+insertCycleBreakerBinding :: TcTyVar -- ^ cbv, must be a CycleBreakerTv+ -> TcType -- ^ cbv's expansion+ -> CycleBreakerVarStack -> CycleBreakerVarStack+insertCycleBreakerBinding cbv expansion (top_env :| rest_envs)+ = ASSERT( (isCycleBreakerTyVar cbv) )+ ((cbv, expansion) : top_env) :| rest_envs++-- | Perform a monadic operation on all pairs in the top environment+-- in the stack.+forAllCycleBreakerBindings_ :: Monad m+ => CycleBreakerVarStack+ -> (TcTyVar -> TcType -> m ()) -> m ()+forAllCycleBreakerBindings_ (top_env :| _rest_envs) action+ = forM_ top_env (uncurry action)+{-# INLINABLE forAllCycleBreakerBindings_ #-} -- to allow SPECIALISE later++ {- Note [Unsolved Derived equalities] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In getUnsolvedInerts, we return a derived equality from the inert_eqs@@ -2671,7 +2716,7 @@ where cbv = F a The cbv is a cycle-breaker var which stands for F a. See- Note [Type variable cycles] in GHC.Tc.Solver.Canonical.+ Note [Type equality cycles] in GHC.Tc.Solver.Canonical. This is just like case 6, and we say "no". Saying "no" here is essential in getting the parser to type-check, with its use of DisambECP. @@ -3221,9 +3266,9 @@ -> TcM a runTcSWithEvBinds = runTcSWithEvBinds' True -runTcSWithEvBinds' :: Bool -- ^ Restore type variable cycles afterwards?+runTcSWithEvBinds' :: Bool -- ^ Restore type equality cycles afterwards? -- Don't if you want to reuse the InertSet.- -- See also Note [Type variable cycles]+ -- See also Note [Type equality cycles] -- in GHC.Tc.Solver.Canonical -> EvBindsVar -> TcS a@@ -3302,7 +3347,8 @@ , tcs_unif_lvl = unif_lvl } -> do { inerts <- TcM.readTcRef old_inert_var- ; let nest_inert = inerts { inert_cycle_breakers = []+ ; let nest_inert = inerts { inert_cycle_breakers = pushCycleBreakerVarStack+ (inert_cycle_breakers inerts) , inert_cans = (inert_cans inerts) { inert_given_eqs = False } } -- All other InertSet fields are inherited@@ -4090,29 +4136,29 @@ {- ************************************************************************ * *- Breaking type variable cycles+ Breaking type equality cycles * * ************************************************************************ -} -- | Conditionally replace all type family applications in the RHS with fresh -- variables, emitting givens that relate the type family application to the--- variable. See Note [Type variable cycles] in GHC.Tc.Solver.Canonical.+-- variable. See Note [Type equality cycles] in GHC.Tc.Solver.Canonical. -- This only works under conditions as described in the Note; otherwise, returns -- Nothing.-breakTyVarCycle_maybe :: CtEvidence+breakTyEqCycle_maybe :: CtEvidence -> CheckTyEqResult -- result of checkTypeEq -> CanEqLHS -> TcType -- RHS- -> TcS (Maybe (TcTyVar, CoercionN, TcType))+ -> TcS (Maybe (CoercionN, TcType)) -- new RHS that doesn't have any type families -- co :: new type ~N old type -- TcTyVar is the LHS tv; convenient for the caller-breakTyVarCycle_maybe (ctLocOrigin . ctEvLoc -> CycleBreakerOrigin _) _ _ _+breakTyEqCycle_maybe (ctLocOrigin . ctEvLoc -> CycleBreakerOrigin _) _ _ _ -- see Detail (7) of Note = return Nothing -breakTyVarCycle_maybe ev cte_result (TyVarLHS lhs_tv) rhs+breakTyEqCycle_maybe ev cte_result lhs rhs | NomEq <- eq_rel , cte_result `cterHasOnlyProblem` cteSolubleOccurs@@ -4121,7 +4167,7 @@ = do { should_break <- final_check ; if should_break then do { (co, new_rhs) <- go rhs- ; return (Just (lhs_tv, co, new_rhs)) }+ ; return (Just (co, new_rhs)) } else return Nothing } where flavour = ctEvFlavour ev@@ -4131,6 +4177,7 @@ | Given <- flavour = return True | ctFlavourContainsDerived flavour+ , TyVarLHS lhs_tv <- lhs = do { result <- touchabilityTest Derived lhs_tv rhs ; return $ case result of Untouchable -> False@@ -4190,11 +4237,11 @@ fun_app new_ty given_term = evCoercion $ mkNomReflCo new_ty -- See Detail (4) of Note ; new_given <- newGivenEvVar new_loc (given_pred, given_term)- ; traceTcS "breakTyVarCycle replacing type family in Given" (ppr new_given)+ ; traceTcS "breakTyEqCycle replacing type family in Given" (ppr new_given) ; emitWorkNC [new_given] ; updInertTcS $ \is ->- is { inert_cycle_breakers = (new_tv, fun_app) :- inert_cycle_breakers is }+ is { inert_cycle_breakers = insertCycleBreakerBinding new_tv fun_app+ (inert_cycle_breakers is) } ; return (mkNomReflCo new_ty, new_ty) } -- Why reflexive? See Detail (4) of the Note @@ -4208,14 +4255,15 @@ new_loc = updateCtLocOrigin (ctEvLoc ev) CycleBreakerOrigin -- does not fit scenario from Note-breakTyVarCycle_maybe _ _ _ _ = return Nothing+breakTyEqCycle_maybe _ _ _ _ = return Nothing -- | Fill in CycleBreakerTvs with the variables they stand for.--- See Note [Type variable cycles] in GHC.Tc.Solver.Canonical.+-- See Note [Type equality cycles] in GHC.Tc.Solver.Canonical. restoreTyVarCycles :: InertSet -> TcM () restoreTyVarCycles is- = forM_ (inert_cycle_breakers is) $ \ (cycle_breaker_tv, orig_ty) ->- TcM.writeMetaTyVar cycle_breaker_tv orig_ty+ = forAllCycleBreakerBindings_ (inert_cycle_breakers is) TcM.writeMetaTyVar+{-# SPECIALISE forAllCycleBreakerBindings_ ::+ CycleBreakerVarStack -> (TcTyVar -> TcType -> TcM ()) -> TcM () #-} -- Unwrap a type synonym only when either: -- The type synonym is forgetful, or
GHC/Tc/TyCl/Instance.hs view
@@ -1577,10 +1577,11 @@ GivenOrigin InstSkol. * When we make a superclass selection from InstSkol we use- a SkolemInfo of (InstSC size), where 'size' is the size of- the constraint whose superclass we are taking. A similarly- when taking the superclass of an InstSC. This is implemented- in GHC.Tc.Solver.Canonical.newSCWorkFromFlavored+ a CtOrigin of (InstSCOrigin size), where 'size' is the size of+ the constraint whose superclass we are taking. And similarly+ when taking the superclass of an InstSCOrigin. This is implemented+ in GHC.Tc.Solver.Canonical.mk_strict_superclasses (in the+ mk_given_loc helper function). Note [Silent superclass arguments] (historical interest only) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
GHC/Tc/TyCl/PatSyn.hs view
@@ -26,7 +26,8 @@ import GHC.Core.Type ( tidyTyCoVarBinders, tidyTypes, tidyType ) import GHC.Core.TyCo.Subst( extendTvSubstWithClone ) import GHC.Tc.Utils.Monad-import GHC.Tc.Gen.Sig ( TcPragEnv, emptyPragEnv, completeSigFromId, lookupPragEnv, addInlinePrags )+import GHC.Tc.Gen.Sig ( TcPragEnv, emptyPragEnv, completeSigFromId, lookupPragEnv+ , addInlinePrags, addInlinePragArity ) import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.Zonk@@ -75,13 +76,16 @@ ************************************************************************ -} -tcPatSynDecl :: PatSynBind GhcRn GhcRn- -> Maybe TcSigInfo+tcPatSynDecl :: LocatedA (PatSynBind GhcRn GhcRn)+ -> TcSigFun -> TcPragEnv -- See Note [Pragmas for pattern synonyms] -> TcM (LHsBinds GhcTc, TcGblEnv)-tcPatSynDecl psb mb_sig prag_fn- = recoverM (recoverPSB psb) $- case mb_sig of+tcPatSynDecl (L loc psb@(PSB { psb_id = L _ name })) sig_fn prag_fn+ = setSrcSpanA loc $+ addErrCtxt (text "In the declaration for pattern synonym"+ <+> quotes (ppr name)) $+ recoverM (recoverPSB psb) $+ case (sig_fn name) of Nothing -> tcInferPatSynDecl psb prag_fn Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi prag_fn _ -> panic "tcPatSynDecl"@@ -144,8 +148,7 @@ tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details , psb_def = lpat, psb_dir = dir }) prag_fn- = addPatSynCtxt lname $- do { traceTc "tcInferPatSynDecl {" $ ppr name+ = do { traceTc "tcInferPatSynDecl {" $ ppr name ; let (arg_names, is_infix) = collectPatSynArgInfo details ; (tclvl, wanted, ((lpat', args), pat_ty))@@ -187,6 +190,16 @@ , not (isEmptyDVarSet bad_cos) ] ; mapM_ dependentArgErr bad_args + -- Report un-quantifiable type variables:+ -- see Note [Unquantified tyvars in a pattern synonym]+ ; dvs <- candidateQTyVarsOfTypes prov_theta+ ; let mk_doc tidy_env+ = do { (tidy_env2, theta) <- zonkTidyTcTypes tidy_env prov_theta+ ; return ( tidy_env2+ , sep [ text "the provided context:"+ , pprTheta theta ] ) }+ ; doNotQuantifyTyVars dvs mk_doc+ ; traceTc "tcInferPatSynDecl }" $ (ppr name $$ ppr ex_tvs) ; rec_fields <- lookupConstructorFields name ; tc_patsyn_finish lname dir is_infix lpat' prag_fn@@ -343,6 +356,27 @@ How to detect this situation? We just look for free coercion variables in the types of any of the arguments to the matcher. The error message is not very helpful, but at least we don't get a Lint error.++Note [Unquantified tyvars in a pattern synonym]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#21479)++ data T a where MkT :: Int -> T Char -- A GADT+ foo :: forall b. Bool -> T b -- Somewhat strange type++ pattern T1 <- (foo -> MkT)++In the view pattern, foo is instantiated, let's say b :-> b0+where b0 is a unification variable. Then matching the GADT+MkT will add the "provided" constraint b0~Char, so we might infer+ pattern T1 :: () => (b0~Char) => Int -> Bool++Nothing constrains that `b0`. We don't want to quantify over it.+We don't want to to zonk to Any (we don't like Any showing up in+user-visible types). So we want to error here. See+Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType++Hence the call to doNotQuantifyTyVars here. -} tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn@@ -356,8 +390,7 @@ , patsig_ex_bndrs = explicit_ex_bndrs, patsig_prov = prov_theta , patsig_body_ty = sig_body_ty } prag_fn- = addPatSynCtxt lname $- do { traceTc "tcCheckPatSynDecl" $+ = do { traceTc "tcCheckPatSynDecl" $ vcat [ ppr implicit_bndrs, ppr explicit_univ_bndrs, ppr req_theta , ppr explicit_ex_bndrs, ppr prov_theta, ppr sig_body_ty ] @@ -638,13 +671,6 @@ InfixCon name1 name2 -> (map unLoc [name1, name2], True) RecCon names -> (map (unLoc . recordPatSynPatVar) names, False) -addPatSynCtxt :: LocatedN Name -> TcM a -> TcM a-addPatSynCtxt (L loc name) thing_inside- = setSrcSpanA loc $- addErrCtxt (text "In the declaration for pattern synonym"- <+> quotes (ppr name)) $- thing_inside- wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a wrongNumberOfParmsErr name decl_arity missing = failWithTc $@@ -746,7 +772,7 @@ -> TcType -> TcM (PatSynMatcher, LHsBinds GhcTc) -- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn-tcPatSynMatcher (L loc name) lpat prag_fn+tcPatSynMatcher (L loc ps_name) lpat prag_fn (univ_tvs, req_theta, req_ev_binds, req_dicts) (ex_tvs, ex_tys, prov_theta, prov_dicts) (args, arg_tys) pat_ty@@ -766,7 +792,7 @@ fail_ty = mkVisFunTyMany unboxedUnitTy res_ty - ; matcher_name <- newImplicitBinder name mkMatcherOcc+ ; matcher_name <- newImplicitBinder ps_name mkMatcherOcc ; scrutinee <- newSysLocalId (fsLit "scrut") Many pat_ty ; cont <- newSysLocalId (fsLit "cont") Many cont_ty ; fail <- newSysLocalId (fsLit "fail") Many fail_ty@@ -802,7 +828,7 @@ , mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty , mg_origin = Generated }- match = mkMatch (mkPrefixFunRhs (L loc name)) []+ match = mkMatch (mkPrefixFunRhs (L loc ps_name)) [] (mkHsLams (rr_tv:res_tv:univ_tvs) req_dicts body') (EmptyLocalBinds noExtField)@@ -811,16 +837,21 @@ , mg_ext = MatchGroupTc [] res_ty , mg_origin = Generated }- prags = lookupPragEnv prag_fn name+ matcher_arity = length req_theta + 3 -- See Note [Pragmas for pattern synonyms] - ; matcher_prag_id <- addInlinePrags matcher_id prags+ -- Add INLINE pragmas; see Note [Pragmas for pattern synonyms]+ -- NB: prag_fn is keyed by the PatSyn Name, not the (internal) matcher name+ ; matcher_prag_id <- addInlinePrags matcher_id $+ map (addInlinePragArity matcher_arity) $+ lookupPragEnv prag_fn ps_name+ ; let bind = FunBind{ fun_id = L loc matcher_prag_id , fun_matches = mg , fun_ext = idHsWrapper , fun_tick = [] } matcher_bind = unitBag (noLocA bind)- ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id))+ ; traceTc "tcPatSynMatcher" (ppr ps_name $$ ppr (idType matcher_id)) ; traceTc "tcPatSynMatcher" (ppr matcher_bind) ; return ((matcher_name, matcher_sigma, is_unlifted), matcher_bind) }@@ -866,6 +897,7 @@ mkPhiTy theta $ mkVisFunTysMany arg_tys $ pat_ty+ ; return (Just (builder_name, builder_sigma, need_dummy_arg)) } tcPatSynBuilderBind :: TcPragEnv@@ -900,12 +932,18 @@ builder_id = modifyIdInfo (`setLevityInfoWithType` pat_ty) $ mkExportedVanillaId builder_name builder_ty -- See Note [Exported LocalIds] in GHC.Types.Id- prags = lookupPragEnv prag_fn ps_name- -- See Note [Pragmas for pattern synonyms]- -- Keyed by the PatSyn Name, not the (internal) builder name - ; builder_id <- addInlinePrags builder_id prags+ (_, req_theta, _, prov_theta, arg_tys, _) = patSynSigBndr patsyn+ builder_arity = length req_theta + length prov_theta+ + length arg_tys+ + (if need_dummy_arg then 1 else 0) + -- Add INLINE pragmas; see Note [Pragmas for pattern synonyms]+ -- NB: prag_fn is keyed by the PatSyn Name, not the (internal) builder name+ ; builder_id <- addInlinePrags builder_id $+ map (addInlinePragArity builder_arity) $+ lookupPragEnv prag_fn ps_name+ ; let match_group' | need_dummy_arg = add_dummy_arg match_group | otherwise = match_group @@ -918,8 +956,7 @@ ; traceTc "tcPatSynBuilderBind {" $ vcat [ ppr patsyn- , ppr builder_id <+> dcolon <+> ppr (idType builder_id)- , ppr prags ]+ , ppr builder_id <+> dcolon <+> ppr (idType builder_id) ] ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLocA bind) ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds ; return builder_binds } } }@@ -1161,18 +1198,19 @@ Note [Pragmas for pattern synonyms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-INLINE and NOINLINE pragmas are supported for pattern synonyms. They affect both-the matcher and the builder.+INLINE and NOINLINE pragmas are supported for pattern synonyms.+They affect both the matcher and the builder. (See Note [Matchers and builders for pattern synonyms] in PatSyn) For example: pattern InlinedPattern x = [x] {-# INLINE InlinedPattern #-}+ pattern NonInlinedPattern x = [x] {-# NOINLINE NonInlinedPattern #-} -For pattern synonyms with explicit builders, only pragma for the entire pattern-synonym is supported. For example:+For pattern synonyms with explicit builders, only a pragma for the+entire pattern synonym is supported. For example: pattern HeadC x <- x:xs where HeadC x = [x] -- This wouldn't compile: {-# INLINE HeadC #-}@@ -1180,6 +1218,14 @@ When no pragma is provided for a pattern, the inlining decision might change between different versions of GHC.++Implementation notes. The prag_fn passed in to tcPatSynDecl will have a binding+for the /pattern synonym/ Name, thus+ InlinedPattern :-> INLINE+From this we cook up an INLINE pragma for the matcher (in tcPatSynMatcher)+and builder (in tcPatSynBuilderBind), by looking up the /pattern synonym/+Name in the prag_fn, and then using addInlinePragArity to add the right+inl_sat field to that INLINE pragma for the matcher or builder respectively. -}
GHC/Tc/TyCl/PatSyn.hs-boot view
@@ -1,14 +1,14 @@ module GHC.Tc.TyCl.PatSyn where import GHC.Hs ( PatSynBind, LHsBinds )-import GHC.Tc.Types ( TcM, TcSigInfo )+import GHC.Tc.Types ( TcM ) import GHC.Tc.Utils.Monad ( TcGblEnv) import GHC.Hs.Extension ( GhcRn, GhcTc )-import Data.Maybe ( Maybe )-import GHC.Tc.Gen.Sig ( TcPragEnv )+import GHC.Tc.Gen.Sig ( TcPragEnv, TcSigFun )+import GHC.Parser.Annotation( LocatedA ) -tcPatSynDecl :: PatSynBind GhcRn GhcRn- -> Maybe TcSigInfo+tcPatSynDecl :: LocatedA (PatSynBind GhcRn GhcRn)+ -> TcSigFun -> TcPragEnv -> TcM (LHsBinds GhcTc, TcGblEnv)
GHC/Tc/Types/Origin.hs view
@@ -191,11 +191,6 @@ -- the type is the instance we are trying to derive | InstSkol -- Bound at an instance decl- | InstSC TypeSize -- A "given" constraint obtained by superclass selection.- -- If (C ty1 .. tyn) is the largest class from- -- which we made a superclass selection in the chain,- -- then TypeSize = sizeTypes [ty1, .., tyn]- -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance | FamInstSkol -- Bound at a family instance decl | PatSkol -- An existential type variable bound by a pattern for@@ -248,7 +243,6 @@ <+> pprWithCommas ppr ips pprSkolInfo (DerivSkol pred) = text "the deriving clause for" <+> quotes (ppr pred) pprSkolInfo InstSkol = text "the instance declaration"-pprSkolInfo (InstSC n) = text "the instance declaration" <> whenPprDebug (parens (ppr n)) pprSkolInfo FamInstSkol = text "a family instance declaration" pprSkolInfo BracketSkol = text "a Template Haskell bracket" pprSkolInfo (RuleSkol name) = text "the RULE" <+> pprRuleName name@@ -340,9 +334,44 @@ -} data CtOrigin- = GivenOrigin SkolemInfo+ = -- | A given constraint from a user-written type signature. The+ -- 'SkolemInfo' inside gives more information.+ GivenOrigin SkolemInfo + -- The following are other origins for given constraints that cannot produce+ -- new skolems -- hence no SkolemInfo.++ -- | 'InstSCOrigin' is used for a Given constraint obtained by superclass selection+ -- from the context of an instance declaration. E.g.+ -- instance @(Foo a, Bar a) => C [a]@ where ...+ -- When typechecking the instance decl itself, including producing evidence+ -- for the superclasses of @C@, the superclasses of @(Foo a)@ and @(Bar a)@ will+ -- have 'InstSCOrigin' origin.+ | InstSCOrigin ScDepth -- ^ The number of superclass selections necessary to+ -- get this constraint; see Note [Replacement vs keeping]+ -- and Note [Use only the best local instance], both in+ -- GHC.Tc.Solver.Interact+ TypeSize -- ^ If @(C ty1 .. tyn)@ is the largest class from+ -- which we made a superclass selection in the chain,+ -- then @TypeSize = sizeTypes [ty1, .., tyn]@+ -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance++ -- | 'OtherSCOrigin' is used for a Given constraint obtained by superclass+ -- selection from a constraint /other than/ the context of an instance+ -- declaration. (For the latter we use 'InstSCOrigin'.) E.g.+ -- f :: Foo a => blah+ -- f = e+ -- When typechecking body of 'f', the superclasses of the Given (Foo a)+ -- will have 'OtherSCOrigin'.+ -- Needed for Note [Replacement vs keeping] and+ -- Note [Use only the best local instance], both in GHC.Tc.Solver.Interact.+ | OtherSCOrigin ScDepth -- ^ The number of superclass selections necessary to+ -- get this constraint+ SkolemInfo -- ^ Where the sub-class constraint arose from+ -- (used only for printing)+ -- All the others are for *wanted* constraints+ | OccurrenceOf Name -- Occurrence of an overloaded identifier | OccurrenceOfRecSel RdrName -- Occurrence of a record selector | AppOrigin -- An application of some kind@@ -386,10 +415,12 @@ | RecordUpdOrigin | ViewPatOrigin - | ScOrigin TypeSize -- Typechecking superclasses of an instance declaration- -- If the instance head is C ty1 .. tyn- -- then TypeSize = sizeTypes [ty1, .., tyn]- -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance+ -- | 'ScOrigin' is used only for the Wanted constraints for the+ -- superclasses of an instance declaration.+ -- If the instance head is @C ty1 .. tyn@+ -- then @TypeSize = sizeTypes [ty1, .., tyn]@+ -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance+ | ScOrigin TypeSize | DerivClauseOrigin -- Typechecking a deriving clause (as opposed to -- standalone deriving).@@ -448,8 +479,13 @@ | CycleBreakerOrigin CtOrigin -- origin of the original constraint- -- See Detail (7) of Note [Type variable cycles] in GHC.Tc.Solver.Canonical+ -- See Detail (7) of Note [Type equality cycles] in GHC.Tc.Solver.Canonical +-- | The number of superclass selections needed to get this Given.+-- If @d :: C ty@ has @ScDepth=2@, then the evidence @d@ will look+-- like @sc_sel (sc_sel dg)@, where @dg@ is a Given.+type ScDepth = Int+ -- An origin is visible if the place where the constraint arises is manifest -- in user code. Currently, all origins are visible except for invisible -- TypeEqOrigins. This is used when choosing which error of@@ -467,6 +503,8 @@ isGivenOrigin :: CtOrigin -> Bool isGivenOrigin (GivenOrigin {}) = True+isGivenOrigin (InstSCOrigin {}) = True+isGivenOrigin (OtherSCOrigin {}) = True isGivenOrigin (FunDepOrigin1 _ o1 _ _ o2 _) = isGivenOrigin o1 && isGivenOrigin o2 isGivenOrigin (FunDepOrigin2 _ o1 _ _) = isGivenOrigin o1 isGivenOrigin (CycleBreakerOrigin o) = isGivenOrigin o@@ -547,7 +585,9 @@ pprCtOrigin :: CtOrigin -> SDoc -- "arising from ..." -- Not an instance of Outputable because of the "arising from" prefix-pprCtOrigin (GivenOrigin sk) = ctoHerald <+> ppr sk+pprCtOrigin (GivenOrigin sk) = ctoHerald <+> ppr sk+pprCtOrigin (InstSCOrigin {}) = ctoHerald <+> pprSkolInfo InstSkol -- keep output in sync+pprCtOrigin (OtherSCOrigin _ si) = ctoHerald <+> pprSkolInfo si pprCtOrigin (SpecPragOrigin ctxt) = case ctxt of
GHC/Tc/Utils/TcMType.hs view
@@ -199,7 +199,7 @@ cloneWanted :: Ct -> TcM Ct cloneWanted ct- | ev@(CtWanted { ctev_pred = pty }) <- ctEvidence ct+ | ev@(CtWanted { ctev_pred = pty, ctev_dest = HoleDest _ }) <- ctEvidence ct = do { co_hole <- newCoercionHole pty ; return (mkNonCanonical (ev { ctev_dest = HoleDest co_hole })) } | otherwise@@ -881,7 +881,7 @@ ; traceTc "cloneAnonMetaTyVar" (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)) ; return tyvar } --- Make a new CycleBreakerTv. See Note [Type variable cycles]+-- Make a new CycleBreakerTv. See Note [Type equality cycles] -- in GHC.Tc.Solver.Canonical. newCycleBreakerTyVar :: TcKind -> TcM TcTyVar newCycleBreakerTyVar kind@@ -1898,28 +1898,34 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider - type C :: Type -> Type -> Constraint+* type C :: Type -> Type -> Constraint class (forall a. a b ~ a c) => C b c -or-- type T = forall a. Proxy a+* type T = forall a. Proxy a -or+* data (forall a. a b ~ a c) => T b c - data (forall a. a b ~ a c) => T b c+* type instance F Int = Proxy Any+ where Any :: forall k. k -We will infer a :: Type -> kappa... but then we get no further information-on kappa. What to do?+In the first three cases we will infer a :: Type -> kappa, but then+we get no further information on kappa. In the last, we will get+ Proxy kappa Any+but again will get no further info on kappa. +What do do? A. We could choose kappa := Type. But this only works when the kind of kappa is Type (true in this example, but not always). B. We could default to Any. C. We could quantify. D. We could error. -We choose (D), as described in #17567. Discussion of alternatives is below.+We choose (D), as described in #17567, and implement this choice in+doNotQuantifyTyVars. Dicsussion of alternativs A-C is below. +NB: this is all rather similar to, but sadly not the same as+ Note [Naughty quantification candidates]+ (One last example: type instance F Int = Proxy Any, where the unconstrained kind variable is the inferred kind of Any. The four examples here illustrate all cases in which this Note applies.)@@ -1938,7 +1944,7 @@ Because no meta-variables remain after quantifying or erroring, we perform the zonk with NoFlexi, which panics upon seeing a meta-variable. -Alternatives not implemented:+Alternatives A-C, not implemented: A. As stated above, this works only sometimes. We might have a free meta-variable of kind Nat, for example.@@ -2521,6 +2527,10 @@ = do { skol_info1 <- zonkSkolemInfo skol_info ; let skol_info2 = tidySkolemInfo env skol_info1 ; return (env, GivenOrigin skol_info2) }+zonkTidyOrigin env (OtherSCOrigin sc_depth skol_info)+ = do { skol_info1 <- zonkSkolemInfo skol_info+ ; let skol_info2 = tidySkolemInfo env skol_info1+ ; return (env, OtherSCOrigin sc_depth skol_info2) } zonkTidyOrigin env orig@(TypeEqOrigin { uo_actual = act , uo_expected = exp }) = do { (env1, act') <- zonkTidyTcType env act
GHC/Tc/Utils/TcType.hs view
@@ -533,7 +533,7 @@ -- It /is/ allowed to unify with a polytype, unlike TauTv | CycleBreakerTv -- Used to fix occurs-check problems in Givens- -- See Note [Type variable cycles] in+ -- See Note [Type equality cycles] in -- GHC.Tc.Solver.Canonical instance Outputable MetaDetails where
GHC/ThToHs.hs view
@@ -1,12 +1,12 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstrainedClassMethods #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -702,8 +702,7 @@ , cd_fld_doc = Nothing}) } cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving GhcPs)-cvtDerivs cs = do { cs' <- mapM cvtDerivClause cs- ; return cs' }+cvtDerivs cs = do { mapM cvtDerivClause cs } cvt_fundep :: TH.FunDep -> CvtM (LHsFunDep GhcPs) cvt_fundep (TH.FunDep xs ys) = do { xs' <- mapM tNameN xs
GHC/Types/Unique/Supply.hs view
@@ -3,11 +3,10 @@ (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-}-{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE UnboxedTuples #-} module GHC.Types.Unique.Supply (
Language/Haskell/Syntax.hs view
@@ -9,15 +9,12 @@ therefore, is almost nothing but re-exporting. -} -{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} -- For deriving instance Data+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-} -- For deriving instance Data- -- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.* module Language.Haskell.Syntax ( module Language.Haskell.Syntax.Binds,
Language/Haskell/Syntax/Binds.hs view
@@ -1,9 +1,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}
Language/Haskell/Syntax/Decls.hs view
@@ -1,13 +1,11 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension {-# LANGUAGE ViewPatterns #-}
Language/Haskell/Syntax/Expr.hs view
@@ -1,15 +1,13 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension
Language/Haskell/Syntax/Pat.hs view
@@ -1,17 +1,14 @@--{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ViewPatterns #-} {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
Language/Haskell/Syntax/Type.hs view
@@ -1,13 +1,11 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension {-
ghc.cabal view
@@ -3,7 +3,7 @@ Cabal-Version: 1.22 Name: ghc-Version: 9.2.2+Version: 9.2.3 License: BSD3 License-File: LICENSE Author: The GHC Team@@ -71,9 +71,9 @@ hpc == 0.6.*, transformers == 0.5.*, exceptions == 0.10.*,- ghc-boot == 9.2.2,- ghc-heap == 9.2.2,- ghci == 9.2.2+ ghc-boot == 9.2.3,+ ghc-heap == 9.2.3,+ ghci == 9.2.3 if os(windows) Build-Depends: Win32 >= 2.3 && < 2.13@@ -127,6 +127,15 @@ -- We need to set the unit id to ghc (without a version number) -- as it's magic. GHC-Options: -this-unit-id ghc++ -- if flag(stage1)+ -- Include-Dirs: stage1+ -- else+ -- if flag(stage2)+ -- Include-Dirs: stage2+ -- else+ -- if flag(stage3)+ -- Include-Dirs: stage2 Install-Includes: HsVersions.h