ghc-lib 0.20200901 → 0.20201001
raw patch · 166 files changed
+11923/−9434 lines, 166 filesdep ~ghc-lib-parser
Dependency ranges changed: ghc-lib-parser
Files
- compiler/GHC.hs +7/−5
- compiler/GHC/Builtin/Types/Literals.hs +5/−5
- compiler/GHC/Builtin/Utils.hs +2/−2
- compiler/GHC/Cmm/DebugBlock.hs +30/−24
- compiler/GHC/Cmm/Info/Build.hs +66/−53
- compiler/GHC/Cmm/LayoutStack.hs +9/−9
- compiler/GHC/Cmm/Lint.hs +48/−45
- compiler/GHC/Cmm/Liveness.hs +17/−17
- compiler/GHC/Cmm/Parser.y +12/−7
- compiler/GHC/Cmm/Pipeline.hs +12/−10
- compiler/GHC/Cmm/Ppr.hs +64/−60
- compiler/GHC/Cmm/Ppr/Decl.hs +40/−44
- compiler/GHC/Cmm/Ppr/Expr.hs +15/−12
- compiler/GHC/Cmm/ProcPoint.hs +4/−6
- compiler/GHC/Cmm/Sink.hs +53/−59
- compiler/GHC/Cmm/Switch/Implement.hs +5/−5
- compiler/GHC/CmmToAsm.hs +18/−12
- compiler/GHC/CmmToAsm/CFG.hs +7/−6
- compiler/GHC/CmmToAsm/Dwarf.hs +6/−6
- compiler/GHC/CmmToAsm/Dwarf/Types.hs +37/−33
- compiler/GHC/CmmToAsm/PIC.hs +1/−1
- compiler/GHC/CmmToAsm/PPC/Ppr.hs +114/−127
- compiler/GHC/CmmToAsm/Ppr.hs +1/−1
- compiler/GHC/CmmToAsm/Reg/Graph.hs +7/−3
- compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs +13/−9
- compiler/GHC/CmmToAsm/Reg/Linear.hs +3/−2
- compiler/GHC/CmmToAsm/Reg/Liveness.hs +15/−9
- compiler/GHC/CmmToAsm/SPARC.hs +1/−1
- compiler/GHC/CmmToAsm/SPARC/CodeGen.hs +2/−1
- compiler/GHC/CmmToAsm/SPARC/CodeGen/CondCode.hs +6/−2
- compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs +3/−1
- compiler/GHC/CmmToAsm/SPARC/CodeGen/Sanity.hs +6/−4
- compiler/GHC/CmmToAsm/SPARC/Ppr.hs +156/−159
- compiler/GHC/CmmToAsm/X86/CodeGen.hs +8/−4
- compiler/GHC/CmmToAsm/X86/Ppr.hs +48/−48
- compiler/GHC/CmmToC.hs +10/−10
- compiler/GHC/CmmToLlvm.hs +1/−1
- compiler/GHC/CmmToLlvm/Base.hs +3/−3
- compiler/GHC/CmmToLlvm/CodeGen.hs +1/−1
- compiler/GHC/Core/Opt/DmdAnal.hs +57/−3
- compiler/GHC/Core/Opt/LiberateCase.hs +25/−23
- compiler/GHC/Core/Opt/Pipeline.hs +44/−14
- compiler/GHC/Core/Opt/Simplify.hs +43/−33
- compiler/GHC/Core/Opt/Simplify/Env.hs +9/−4
- compiler/GHC/Core/Opt/Simplify/Monad.hs +17/−5
- compiler/GHC/Core/Opt/Simplify/Utils.hs +16/−9
- compiler/GHC/Core/Opt/SpecConstr.hs +4/−2
- compiler/GHC/Core/Opt/Specialise.hs +156/−169
- compiler/GHC/Core/Opt/WorkWrap.hs +9/−4
- compiler/GHC/Core/Rules.hs +4/−4
- compiler/GHC/CoreToByteCode.hs +4/−4
- compiler/GHC/CoreToStg.hs +1/−1
- compiler/GHC/Driver/Backpack.hs +6/−4
- compiler/GHC/Driver/CodeOutput.hs +9/−7
- compiler/GHC/Driver/Finder.hs +1/−0
- compiler/GHC/Driver/Main.hs +14/−10
- compiler/GHC/Driver/Make.hs +4/−3
- compiler/GHC/Driver/Pipeline.hs +69/−7
- compiler/GHC/HsToCore.hs +11/−6
- compiler/GHC/HsToCore/Binds.hs +21/−17
- compiler/GHC/HsToCore/Coverage.hs +18/−21
- compiler/GHC/HsToCore/Docs.hs +10/−4
- compiler/GHC/HsToCore/Expr.hs +15/−17
- compiler/GHC/HsToCore/Foreign/Decl.hs +27/−12
- compiler/GHC/HsToCore/GuardedRHSs.hs +29/−29
- compiler/GHC/HsToCore/ListComp.hs +1/−1
- compiler/GHC/HsToCore/Match.hs +43/−44
- compiler/GHC/HsToCore/Match.hs-boot +1/−0
- compiler/GHC/HsToCore/Monad.hs +28/−29
- compiler/GHC/HsToCore/PmCheck.hs +0/−1421
- compiler/GHC/HsToCore/PmCheck/Oracle.hs +0/−1787
- compiler/GHC/HsToCore/PmCheck/Ppr.hs +0/−223
- compiler/GHC/HsToCore/Pmc.hs +516/−0
- compiler/GHC/HsToCore/Pmc/Check.hs +277/−0
- compiler/GHC/HsToCore/Pmc/Desugar.hs +523/−0
- compiler/GHC/HsToCore/Pmc/Ppr.hs +223/−0
- compiler/GHC/HsToCore/Pmc/Solver.hs +1733/−0
- compiler/GHC/HsToCore/Pmc/Solver/Types.hs +639/−0
- compiler/GHC/HsToCore/Pmc/Types.hs +241/−0
- compiler/GHC/HsToCore/Pmc/Utils.hs +140/−0
- compiler/GHC/HsToCore/Quote.hs +9/−5
- compiler/GHC/HsToCore/Types.hs +85/−0
- compiler/GHC/HsToCore/Usage.hs +1/−0
- compiler/GHC/Iface/Ext/Ast.hs +27/−25
- compiler/GHC/Iface/Ext/Debug.hs +2/−3
- compiler/GHC/Iface/Ext/Types.hs +39/−6
- compiler/GHC/Iface/Ext/Utils.hs +13/−13
- compiler/GHC/Iface/Load.hs +6/−9
- compiler/GHC/Iface/Make.hs +8/−6
- compiler/GHC/Iface/Recomp.hs +5/−4
- compiler/GHC/Iface/Rename.hs +1/−0
- compiler/GHC/Iface/Tidy.hs +50/−49
- compiler/GHC/Iface/Tidy/StaticPtrTable.hs +5/−5
- compiler/GHC/Iface/UpdateIdInfos.hs +2/−8
- compiler/GHC/IfaceToCore.hs +31/−23
- compiler/GHC/IfaceToCore.hs-boot +6/−6
- compiler/GHC/Rename/Expr.hs +0/−1
- compiler/GHC/Rename/HsType.hs +65/−53
- compiler/GHC/Rename/Module.hs +13/−3
- compiler/GHC/Rename/Names.hs +3/−3
- compiler/GHC/Rename/Pat.hs +1/−1
- compiler/GHC/Runtime/Eval.hs +10/−50
- compiler/GHC/Runtime/Heap/Inspect.hs +48/−2
- compiler/GHC/Runtime/Linker.hs +15/−12
- compiler/GHC/Settings/IO.hs +5/−1
- compiler/GHC/Stg/Lint.hs +2/−2
- compiler/GHC/Stg/Unarise.hs +3/−3
- compiler/GHC/StgToCmm/Bind.hs +6/−5
- compiler/GHC/StgToCmm/Closure.hs +13/−4
- compiler/GHC/StgToCmm/DataCon.hs +1/−1
- compiler/GHC/StgToCmm/Expr.hs +1/−1
- compiler/GHC/StgToCmm/Layout.hs +4/−3
- compiler/GHC/StgToCmm/Monad.hs +6/−3
- compiler/GHC/StgToCmm/Prim.hs +12/−12
- compiler/GHC/StgToCmm/Utils.hs +1/−1
- compiler/GHC/SysTools.hs +20/−7
- compiler/GHC/SysTools/Tasks.hs +50/−0
- compiler/GHC/Tc/Deriv.hs +7/−2
- compiler/GHC/Tc/Deriv/Generate.hs +9/−15
- compiler/GHC/Tc/Errors.hs +44/−28
- compiler/GHC/Tc/Errors/Hole.hs +2/−2
- compiler/GHC/Tc/Gen/App.hs +1088/−0
- compiler/GHC/Tc/Gen/Arrow.hs +2/−1
- compiler/GHC/Tc/Gen/Bind.hs +11/−102
- compiler/GHC/Tc/Gen/Default.hs +1/−1
- compiler/GHC/Tc/Gen/Expr.hs +1642/−2907
- compiler/GHC/Tc/Gen/Expr.hs-boot +3/−7
- compiler/GHC/Tc/Gen/Foreign.hs +19/−10
- compiler/GHC/Tc/Gen/Head.hs +1143/−0
- compiler/GHC/Tc/Gen/HsType.hs +248/−178
- compiler/GHC/Tc/Gen/Match.hs +10/−2
- compiler/GHC/Tc/Gen/Pat.hs +2/−3
- compiler/GHC/Tc/Gen/Sig.hs +37/−56
- compiler/GHC/Tc/Gen/Splice.hs +10/−4
- compiler/GHC/Tc/Instance/Class.hs +3/−4
- compiler/GHC/Tc/Module.hs +50/−56
- compiler/GHC/Tc/Solver.hs +144/−143
- compiler/GHC/Tc/Solver/Canonical.hs +19/−7
- compiler/GHC/Tc/Solver/Interact.hs +6/−3
- compiler/GHC/Tc/Solver/Monad.hs +42/−22
- compiler/GHC/Tc/TyCl.hs +193/−194
- compiler/GHC/Tc/TyCl/Instance.hs +19/−16
- compiler/GHC/Tc/TyCl/PatSyn.hs +6/−16
- compiler/GHC/Tc/TyCl/PatSyn.hs-boot +0/−2
- compiler/GHC/Tc/TyCl/Utils.hs +0/−5
- compiler/GHC/Tc/Utils/Backpack.hs +1/−0
- compiler/GHC/Tc/Utils/Env.hs +2/−2
- compiler/GHC/Tc/Utils/Instantiate.hs +33/−54
- compiler/GHC/Tc/Utils/Monad.hs +35/−19
- compiler/GHC/Tc/Utils/TcMType.hs +81/−42
- compiler/GHC/Tc/Utils/Unify.hs +228/−216
- compiler/GHC/Tc/Utils/Unify.hs-boot +5/−5
- compiler/GHC/Tc/Utils/Zonk.hs +8/−3
- compiler/GHC/Tc/Validity.hs +140/−48
- compiler/GHC/ThToHs.hs +17/−4
- compiler/GHC/Types/Unique/SDFM.hs +121/−0
- compiler/GhclibHsVersions.h +4/−4
- ghc-lib.cabal +18/−7
- ghc-lib/stage0/compiler/build/GHC/Platform/Constants.hs +0/−135
- ghc-lib/stage0/compiler/build/primop-code-size.hs-incl +4/−4
- ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl +12/−12
- ghc-lib/stage0/compiler/build/primop-list.hs-incl +12/−12
- ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl +12/−12
- ghc-lib/stage0/compiler/build/primop-tag.hs-incl +12/−12
- ghc-lib/stage0/lib/ghcversion.h +3/−3
- ghc-lib/stage0/lib/settings +2/−0
compiler/GHC.hs view
@@ -303,6 +303,7 @@ import GHC.Core.Ppr.TyThing ( pprFamInst ) import GHC.Driver.Backend+import GHC.Driver.Config import GHC.Driver.Main import GHC.Driver.Make import GHC.Driver.Hooks@@ -313,6 +314,7 @@ import GHC.Tc.Types import GHC.Core.Predicate import GHC.Unit+import GHC.Unit.State import GHC.Types.Name.Set import GHC.Types.Name.Reader import GHC.Hs@@ -1425,9 +1427,9 @@ -- Throws a 'GHC.Driver.Types.SourceError' on parse error. getTokenStream :: GhcMonad m => Module -> m [Located Token] getTokenStream mod = do- (sourceFile, source, flags) <- getModuleSourceAndFlags mod+ (sourceFile, source, dflags) <- getModuleSourceAndFlags mod let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1- case lexTokenStream source startLoc flags of+ case lexTokenStream (initParserOpts dflags) source startLoc of POk _ ts -> return ts PFailed pst -> do dflags <- getDynFlags@@ -1438,9 +1440,9 @@ -- 'showRichTokenStream'. getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)] getRichTokenStream mod = do- (sourceFile, source, flags) <- getModuleSourceAndFlags mod+ (sourceFile, source, dflags) <- getModuleSourceAndFlags mod let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1- case lexTokenStream source startLoc flags of+ case lexTokenStream (initParserOpts dflags) source startLoc of POk _ ts -> return $ addSourceToTokens startLoc source ts PFailed pst -> do dflags <- getDynFlags@@ -1615,7 +1617,7 @@ loc = mkRealSrcLoc (mkFastString filename) 1 1 buf = stringToStringBuffer str in- case unP Parser.parseModule (mkPState dflags buf loc) of+ case unP Parser.parseModule (initParserState (initParserOpts dflags) buf loc) of PFailed pst -> let (warns,errs) = getMessages pst dflags in
compiler/GHC/Builtin/Types/Literals.hs view
@@ -32,6 +32,7 @@ import GHC.Tc.Types.Constraint ( Xi ) import GHC.Core.Coercion.Axiom ( CoAxiomRule(..), BuiltInSynFamily(..), TypeEqn ) import GHC.Types.Name ( Name, BuiltInSyntax(..) )+import GHC.Types.Unique.FM import GHC.Builtin.Types import GHC.Builtin.Types.Prim ( mkTemplateAnonTyConBinders ) import GHC.Builtin.Names@@ -50,7 +51,6 @@ , typeSymbolAppendFamNameKey ) import GHC.Data.FastString-import qualified Data.Map as Map import Data.Maybe ( isJust ) import Control.Monad ( guard ) import Data.List ( isPrefixOf, isSuffixOf )@@ -401,7 +401,7 @@ s2' <- isStrLitTy s2 t2' <- isStrLitTy t2 return (mkTyConApp typeSymbolCmpTyCon [s1,t1] ===- ordering (compare s2' t2')) }+ ordering (lexicalCompareFS s2' t2')) } axAppendSymbolDef = CoAxiomRule { coaxrName = fsLit "AppendSymbolDef"@@ -457,8 +457,8 @@ -- The list of built-in type family axioms that GHC uses. -- If you define new axioms, make sure to include them in this list. -- See Note [Adding built-in type families]-typeNatCoAxiomRules :: Map.Map FastString CoAxiomRule-typeNatCoAxiomRules = Map.fromList $ map (\x -> (coaxrName x, x))+typeNatCoAxiomRules :: UniqFM FastString CoAxiomRule+typeNatCoAxiomRules = listToUFM $ map (\x -> (coaxrName x, x)) [ axAddDef , axMulDef , axExpDef@@ -706,7 +706,7 @@ matchFamCmpSymbol :: [Type] -> Maybe (CoAxiomRule, [Type], Type) matchFamCmpSymbol [s,t] | Just x <- mbX, Just y <- mbY =- Just (axCmpSymbolDef, [s,t], ordering (compare x y))+ Just (axCmpSymbolDef, [s,t], ordering (lexicalCompareFS x y)) | tcEqType s t = Just (axCmpSymbolRefl, [s], ordering EQ) where mbX = isStrLitTy s mbY = isStrLitTy t
compiler/GHC/Builtin/Utils.hs view
@@ -71,7 +71,7 @@ import GHC.Core.Class import GHC.Core.TyCon import GHC.Types.Unique.FM-import GHC.Utils.Misc+import GHC.Utils.Misc as Utils import GHC.Utils.Panic import GHC.Builtin.Types.Literals ( typeNatTyCons ) import GHC.Hs.Doc@@ -180,7 +180,7 @@ | otherwise = Just badNamesStr where- namesEnv = foldl' (\m n -> extendNameEnv_Acc (:) singleton m n n)+ namesEnv = foldl' (\m n -> extendNameEnv_Acc (:) Utils.singleton m n n) emptyUFM all_names badNamesEnv = filterNameEnv (\ns -> ns `lengthExceeds` 1) namesEnv badNamesPairs = nonDetUFMToList badNamesEnv
compiler/GHC/Cmm/DebugBlock.hs view
@@ -1,7 +1,12 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-} + {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -----------------------------------------------------------------------------@@ -72,19 +77,20 @@ , dblBlocks :: ![DebugBlock] -- ^ Nested blocks } -instance Outputable DebugBlock where- ppr blk = (if | dblProcedure blk == dblLabel blk+instance OutputableP env CLabel => OutputableP env DebugBlock where+ pdoc env blk =+ (if | dblProcedure blk == dblLabel blk -> text "proc" | dblHasInfoTbl blk -> text "pp-blk" | otherwise -> text "blk") <+>- ppr (dblLabel blk) <+> parens (ppr (dblCLabel blk)) <+>+ ppr (dblLabel blk) <+> parens (pdoc env (dblCLabel blk)) <+> (maybe empty ppr (dblSourceTick blk)) <+> (maybe (text "removed") ((text "pos " <>) . ppr) (dblPosition blk)) <+>- (ppr (dblUnwind blk)) $+$- (if null (dblBlocks blk) then empty else nest 4 (ppr (dblBlocks blk)))+ (pdoc env (dblUnwind blk)) $+$+ (if null (dblBlocks blk) then empty else nest 4 (pdoc env (dblBlocks blk))) -- | Intermediate data structure holding debug-relevant context information -- about a block.@@ -489,12 +495,12 @@ -- | A label associated with an 'UnwindTable' data UnwindPoint = UnwindPoint !CLabel !UnwindTable -instance Outputable UnwindPoint where- ppr (UnwindPoint lbl uws) =- braces $ ppr lbl<>colon+instance OutputableP env CLabel => OutputableP env UnwindPoint where+ pdoc env (UnwindPoint lbl uws) =+ braces $ pdoc env lbl <> colon <+> hsep (punctuate comma $ map pprUw $ Map.toList uws) where- pprUw (g, expr) = ppr g <> char '=' <> ppr expr+ pprUw (g, expr) = ppr g <> char '=' <> pdoc env expr -- | Maps registers to expressions that yield their "old" values -- further up the stack. Most interesting for the stack pointer @Sp@,@@ -513,19 +519,19 @@ | UwTimes UnwindExpr UnwindExpr deriving (Eq) -instance Outputable UnwindExpr where- pprPrec _ (UwConst i) = ppr i- pprPrec _ (UwReg g 0) = ppr g- pprPrec p (UwReg g x) = pprPrec p (UwPlus (UwReg g 0) (UwConst x))- pprPrec _ (UwDeref e) = char '*' <> pprPrec 3 e- pprPrec _ (UwLabel l) = pprPrec 3 l- pprPrec p (UwPlus e0 e1) | p <= 0- = pprPrec 0 e0 <> char '+' <> pprPrec 0 e1- pprPrec p (UwMinus e0 e1) | p <= 0- = pprPrec 1 e0 <> char '-' <> pprPrec 1 e1- pprPrec p (UwTimes e0 e1) | p <= 1- = pprPrec 2 e0 <> char '*' <> pprPrec 2 e1- pprPrec _ other = parens (pprPrec 0 other)+instance OutputableP env CLabel => OutputableP env UnwindExpr where+ pdocPrec _ _ (UwConst i) = ppr i+ pdocPrec _ _ (UwReg g 0) = ppr g+ pdocPrec p env (UwReg g x) = pdocPrec p env (UwPlus (UwReg g 0) (UwConst x))+ pdocPrec _ env (UwDeref e) = char '*' <> pdocPrec 3 env e+ pdocPrec _ env (UwLabel l) = pdocPrec 3 env l+ pdocPrec p env (UwPlus e0 e1) | p <= 0+ = pdocPrec 0 env e0 <> char '+' <> pdocPrec 0 env e1+ pdocPrec p env (UwMinus e0 e1) | p <= 0+ = pdocPrec 1 env e0 <> char '-' <> pdocPrec 1 env e1+ pdocPrec p env (UwTimes e0 e1) | p <= 1+ = pdocPrec 2 env e0 <> char '*' <> pdocPrec 2 env e1+ pdocPrec _ env other = parens (pdocPrec 0 env other) -- | Conversion of Cmm expressions to unwind expressions. We check for -- unsupported operator usages and simplify the expression as far as@@ -549,5 +555,5 @@ (MO_Mul{}, u1, u2 ) -> UwTimes u1 u2 _otherwise -> pprPanic "Unsupported operator in unwind expression!" (pprExpr platform e)-toUnwindExpr _ e- = pprPanic "Unsupported unwind expression!" (ppr e)+toUnwindExpr platform e+ = pprPanic "Unsupported unwind expression!" (pdoc platform e)
compiler/GHC/Cmm/Info/Build.hs view
@@ -1,7 +1,14 @@ {-# LANGUAGE GADTs, BangPatterns, RecordWildCards, GeneralizedNewtypeDeriving, NondecreasingIndentation, TupleSections,- ScopedTypeVariables, OverloadedStrings #-}+ ScopedTypeVariables, OverloadedStrings, LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-} + module GHC.Cmm.Info.Build ( CAFSet, CAFEnv, cafAnal, cafAnalData , doSRTs, ModuleSRTInfo (..), emptySRT@@ -455,8 +462,10 @@ -- map them to SRTEntry later, which ranges over labels that do exist. -- newtype CAFLabel = CAFLabel CLabel- deriving (Eq,Ord,Outputable)+ deriving (Eq,Ord) +deriving newtype instance OutputableP env CLabel => OutputableP env CAFLabel+ type CAFSet = Set CAFLabel type CAFEnv = LabelMap CAFSet @@ -466,8 +475,11 @@ -- This is a label that we can put in an SRT. It *must* be a closure label, -- pointing to either a FUN_STATIC, THUNK_STATIC, or CONSTR. newtype SRTEntry = SRTEntry CLabel- deriving (Eq, Ord, Outputable)+ deriving (Eq, Ord) +deriving newtype instance OutputableP env CLabel => OutputableP env SRTEntry++ -- --------------------------------------------------------------------- -- CAF analysis @@ -571,12 +583,12 @@ _ -> set in- srtTrace "cafTransfers" (text "block:" <+> ppr block $$- text "contLbls:" <+> ppr contLbls $$- text "entry:" <+> ppr entry $$- text "topLbl:" <+> ppr topLbl $$- text "cafs in exit:" <+> ppr joined $$- text "result:" <+> ppr result) $+ srtTrace "cafTransfers" (text "block:" <+> pdoc platform block $$+ text "contLbls:" <+> ppr contLbls $$+ text "entry:" <+> ppr entry $$+ text "topLbl:" <+> pdoc platform topLbl $$+ text "cafs in exit:" <+> pdoc platform joined $$+ text "result:" <+> pdoc platform result) $ mapSingleton (entryLabel eNode) result @@ -597,12 +609,12 @@ , moduleSRTMap :: SRTMap } -instance Outputable ModuleSRTInfo where- ppr ModuleSRTInfo{..} =+instance OutputableP env CLabel => OutputableP env ModuleSRTInfo where+ pdoc env ModuleSRTInfo{..} = text "ModuleSRTInfo {" $$- (nest 4 $ text "dedupSRTs =" <+> ppr dedupSRTs $$- text "flatSRTs =" <+> ppr flatSRTs $$- text "moduleSRTMap =" <+> ppr moduleSRTMap) $$ char '}'+ (nest 4 $ text "dedupSRTs =" <+> pdoc env dedupSRTs $$+ text "flatSRTs =" <+> pdoc env flatSRTs $$+ text "moduleSRTMap =" <+> pdoc env moduleSRTMap) $$ char '}' emptySRT :: Module -> ModuleSRTInfo emptySRT mod =@@ -635,9 +647,10 @@ | DeclLabel CLabel deriving (Eq, Ord) -instance Outputable SomeLabel where- ppr (BlockLabel l) = text "b:" <+> ppr l- ppr (DeclLabel l) = text "s:" <+> ppr l+instance OutputableP env CLabel => OutputableP env SomeLabel where+ pdoc env = \case+ BlockLabel l -> text "b:" <+> pdoc env l+ DeclLabel l -> text "s:" <+> pdoc env l getBlockLabel :: SomeLabel -> Maybe Label getBlockLabel (BlockLabel l) = Just l@@ -672,9 +685,9 @@ -> [CmmDecl] -> [SCC (SomeLabel, CAFLabel, Set CAFLabel)] depAnalSRTs platform cafEnv cafEnv_static decls =- srtTrace "depAnalSRTs" (text "decls:" <+> ppr decls $$- text "nodes:" <+> ppr (map node_payload nodes) $$- text "graph:" <+> ppr graph) graph+ srtTrace "depAnalSRTs" (text "decls:" <+> pdoc platform decls $$+ text "nodes:" <+> pdoc platform (map node_payload nodes) $$+ text "graph:" <+> pdoc platform graph) graph where labelledBlocks :: [(SomeLabel, CAFLabel)] labelledBlocks = concatMap (getLabelledBlocks platform) decls@@ -749,7 +762,7 @@ -- | resolve a CAFLabel to its SRTEntry using the SRTMap resolveCAF :: Platform -> SRTMap -> CAFLabel -> Maybe SRTEntry resolveCAF platform srtMap lbl@(CAFLabel l) =- srtTrace "resolveCAF" ("l:" <+> ppr l <+> "resolved:" <+> ppr ret) ret+ srtTrace "resolveCAF" ("l:" <+> pdoc platform l <+> "resolved:" <+> pdoc platform ret) ret where ret = Map.findWithDefault (Just (SRTEntry (toClosureLbl platform l))) lbl srtMap @@ -777,7 +790,7 @@ \(set, decl) -> case decl of CmmProc{} ->- pprPanic "doSRTs" (text "Proc in static data list:" <+> ppr decl)+ pprPanic "doSRTs" (text "Proc in static data list:" <+> pdoc platform decl) CmmData _ static -> case static of CmmStatics lbl _ _ _ -> (lbl, set)@@ -806,11 +819,11 @@ cafsWithSRTs :: [(Label, CAFLabel, Set CAFLabel)] cafsWithSRTs = getCAFs platform cafEnv decls - srtTraceM "doSRTs" (text "data:" <+> ppr data_ $$- text "procs:" <+> ppr procs $$- text "static_data_env:" <+> ppr static_data_env $$- text "sccs:" <+> ppr sccs $$- text "cafsWithSRTs:" <+> ppr cafsWithSRTs)+ srtTraceM "doSRTs" (text "data:" <+> pdoc platform data_ $$+ text "procs:" <+> pdoc platform procs $$+ text "static_data_env:" <+> pdoc platform static_data_env $$+ text "sccs:" <+> pdoc platform sccs $$+ text "cafsWithSRTs:" <+> pdoc platform cafsWithSRTs) -- On each strongly-connected group of decls, construct the SRT -- closures and the SRT fields for info tables.@@ -860,7 +873,7 @@ -- Not an IdLabel, ignore srtMap CmmProc{} ->- pprPanic "doSRTs" (text "Found Proc in static data list:" <+> ppr decl))+ pprPanic "doSRTs" (text "Found Proc in static data list:" <+> pdoc platform decl)) (moduleSRTMap moduleSRTInfo') data_ return (moduleSRTInfo'{ moduleSRTMap = srtMap_w_raws }, srt_decls ++ decls')@@ -966,18 +979,18 @@ filtered0 = Set.fromList resolved `Set.difference` allBelow srtTraceM "oneSRT:"- (text "srtMap:" <+> ppr srtMap $$- text "nonRec:" <+> ppr nonRec $$- text "lbls:" <+> ppr lbls $$- text "caf_lbls:" <+> ppr caf_lbls $$- text "static_data:" <+> ppr static_data $$- text "cafs:" <+> ppr cafs $$- text "blockids:" <+> ppr blockids $$- text "maybeFunClosure:" <+> ppr maybeFunClosure $$- text "otherFunLabels:" <+> ppr otherFunLabels $$- text "resolved:" <+> ppr resolved $$- text "allBelow:" <+> ppr allBelow $$- text "filtered0:" <+> ppr filtered0)+ (text "srtMap:" <+> pdoc platform srtMap $$+ 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 "cafs:" <+> pdoc platform cafs $$+ text "blockids:" <+> ppr blockids $$+ text "maybeFunClosure:" <+> pdoc platform maybeFunClosure $$+ text "otherFunLabels:" <+> pdoc platform otherFunLabels $$+ text "resolved:" <+> pdoc platform resolved $$+ text "allBelow:" <+> pdoc platform allBelow $$+ text "filtered0:" <+> pdoc platform filtered0) let isStaticFun = isJust maybeFunClosure@@ -989,7 +1002,7 @@ updateSRTMap :: Maybe SRTEntry -> StateT ModuleSRTInfo UniqSM () updateSRTMap srtEntry = srtTrace "updateSRTMap"- (ppr srtEntry <+> "isCAF:" <+> ppr isCAF <+>+ (pdoc platform srtEntry <+> "isCAF:" <+> ppr isCAF <+> "isStaticFun:" <+> ppr isStaticFun) $ when (not isCAF && (not isStaticFun || isNothing srtEntry)) $ modify' $ \state ->@@ -1012,7 +1025,7 @@ all (\(CAFLabel clbl) -> Set.member clbl static_data) caf_lbls if Set.null filtered0 then do- srtTraceM "oneSRT: empty" (ppr caf_lbls)+ srtTraceM "oneSRT: empty" (pdoc platform caf_lbls) updateSRTMap Nothing return ([], [], [], False) else do@@ -1021,8 +1034,8 @@ let allBelow_funs = Set.fromList (map (SRTEntry . toClosureLbl platform) otherFunLabels) let filtered = filtered0 `Set.union` allBelow_funs- srtTraceM "oneSRT" (text "filtered:" <+> ppr filtered $$- text "allBelow_funs:" <+> ppr allBelow_funs)+ srtTraceM "oneSRT" (text "filtered:" <+> pdoc platform filtered $$+ text "allBelow_funs:" <+> pdoc platform allBelow_funs) case Set.toList filtered of [] -> pprPanic "oneSRT" empty -- unreachable @@ -1054,8 +1067,8 @@ [ (b, if b == staticFunBlock then lbl else staticFunLbl) | b <- blockids ] Nothing -> do- srtTraceM "oneSRT: one" (text "caf_lbls:" <+> ppr caf_lbls $$- text "one:" <+> ppr one)+ srtTraceM "oneSRT: one" (text "caf_lbls:" <+> pdoc platform caf_lbls $$+ text "one:" <+> pdoc platform one) updateSRTMap (Just one) return ([], map (,lbl) blockids, [], True) @@ -1067,7 +1080,7 @@ -- Implements the [Common] optimisation. case Map.lookup filtered (dedupSRTs topSRT) of Just srtEntry@(SRTEntry srtLbl) -> do- srtTraceM "oneSRT [Common]" (ppr caf_lbls <+> ppr srtLbl)+ srtTraceM "oneSRT [Common]" (pdoc platform caf_lbls <+> pdoc platform srtLbl) updateSRTMap (Just srtEntry) return ([], map (,srtLbl) blockids, [], True) Nothing -> do@@ -1087,11 +1100,11 @@ newDedupSRTs = Map.insert filtered srtEntry (dedupSRTs topSRT) modify' (\state -> state{ dedupSRTs = newDedupSRTs, flatSRTs = newFlatSRTs })- srtTraceM "oneSRT: new" (text "caf_lbls:" <+> ppr caf_lbls $$- text "filtered:" <+> ppr filtered $$- text "srtEntry:" <+> ppr srtEntry $$- text "newDedupSRTs:" <+> ppr newDedupSRTs $$- text "newFlatSRTs:" <+> ppr newFlatSRTs)+ srtTraceM "oneSRT: new" (text "caf_lbls:" <+> pdoc platform caf_lbls $$+ text "filtered:" <+> pdoc platform filtered $$+ text "srtEntry:" <+> pdoc platform srtEntry $$+ text "newDedupSRTs:" <+> pdoc platform newDedupSRTs $$+ text "newFlatSRTs:" <+> pdoc platform newFlatSRTs) let SRTEntry lbl = srtEntry return (decls, map (,lbl) blockids, funSRTs, True) @@ -1179,7 +1192,7 @@ -- if we don't add SRT entries to this closure, then we -- want to set the srt field in its info table as usual (info_tbl { cit_srt = mapLookup (g_entry g) srt_env }, [])- Just srtEntries -> srtTrace "maybeStaticFun" (ppr res)+ Just srtEntries -> srtTrace "maybeStaticFun" (pdoc (profilePlatform profile) res) (info_tbl { cit_rep = new_rep }, res) where res = [ CmmLabel lbl | SRTEntry lbl <- srtEntries ] fields = mkStaticClosureFields profile info_tbl ccs caf_info srtEntries
compiler/GHC/Cmm/LayoutStack.hs view
@@ -246,9 +246,10 @@ = do -- We need liveness info. Dead assignments are removed later -- by the sinking pass.- let liveness = cmmLocalLiveness dflags graph+ let liveness = cmmLocalLiveness platform graph blocks = revPostorder graph- profile = targetProfile dflags+ profile = targetProfile dflags+ platform = profilePlatform profile (final_stackmaps, _final_high_sp, new_blocks) <- mfix $ \ ~(rec_stackmaps, rec_high_sp, _new_blocks) ->@@ -256,7 +257,7 @@ rec_stackmaps rec_high_sp blocks blocks_with_reloads <-- insertReloadsAsNeeded dflags procpoints final_stackmaps entry new_blocks+ insertReloadsAsNeeded platform procpoints final_stackmaps entry new_blocks new_blocks' <- mapM (lowerSafeForeignCall profile) blocks_with_reloads return (ofBlockList entry new_blocks', final_stackmaps) @@ -1022,7 +1023,7 @@ get_liveness :: BlockId -> Liveness get_liveness lbl = case mapLookup lbl stackmaps of- Nothing -> pprPanic "setInfoTableStackMap" (ppr lbl <+> ppr info_tbls)+ Nothing -> pprPanic "setInfoTableStackMap" (ppr lbl <+> pdoc platform info_tbls) Just sm -> stackMapToLiveness platform sm setInfoTableStackMap _ _ d = d@@ -1044,30 +1045,29 @@ -- ----------------------------------------------------------------------------- insertReloadsAsNeeded- :: DynFlags+ :: Platform -> ProcPointSet -> LabelMap StackMap -> BlockId -> [CmmBlock] -> UniqSM [CmmBlock]-insertReloadsAsNeeded dflags procpoints final_stackmaps entry blocks = do+insertReloadsAsNeeded platform procpoints final_stackmaps entry blocks = do toBlockList . fst <$> rewriteCmmBwd liveLattice rewriteCC (ofBlockList entry blocks) mapEmpty where rewriteCC :: RewriteFun CmmLocalLive rewriteCC (BlockCC e_node middle0 x_node) fact_base0 = do let entry_label = entryLabel e_node- platform = targetPlatform dflags stackmap = case mapLookup entry_label final_stackmaps of Just sm -> sm Nothing -> panic "insertReloadsAsNeeded: rewriteCC: stackmap" -- Merge the liveness from successor blocks and analyse the last -- node.- joined = gen_kill dflags x_node $!+ joined = gen_kill platform x_node $! joinOutFacts liveLattice x_node fact_base0 -- What is live at the start of middle0.- live_at_middle0 = foldNodesBwdOO (gen_kill dflags) middle0 joined+ live_at_middle0 = foldNodesBwdOO (gen_kill platform) middle0 joined -- If this is a procpoint we need to add the reloads, but only if -- they're actually live. Furthermore, nothing is live at the entry
compiler/GHC/Cmm/Lint.hs view
@@ -26,7 +26,6 @@ import GHC.Cmm.Switch (switchTargetsToList) import GHC.Cmm.Ppr () -- For Outputable instances import GHC.Utils.Outputable-import GHC.Driver.Session import Control.Monad (ap, unless) @@ -38,38 +37,41 @@ -- ----------------------------------------------------------------------------- -- Exported entry points: -cmmLint :: (Outputable d, Outputable h)- => DynFlags -> GenCmmGroup d h CmmGraph -> Maybe SDoc-cmmLint dflags tops = runCmmLint dflags (mapM_ (lintCmmDecl dflags)) tops+cmmLint :: (OutputableP Platform d, OutputableP Platform h)+ => Platform -> GenCmmGroup d h CmmGraph -> Maybe SDoc+cmmLint platform tops = runCmmLint platform (mapM_ lintCmmDecl) tops -cmmLintGraph :: DynFlags -> CmmGraph -> Maybe SDoc-cmmLintGraph dflags g = runCmmLint dflags (lintCmmGraph dflags) g+cmmLintGraph :: Platform -> CmmGraph -> Maybe SDoc+cmmLintGraph platform g = runCmmLint platform lintCmmGraph g -runCmmLint :: Outputable a => DynFlags -> (a -> CmmLint b) -> a -> Maybe SDoc-runCmmLint dflags l p =- case unCL (l p) dflags of+runCmmLint :: OutputableP Platform a => Platform -> (a -> CmmLint b) -> a -> Maybe SDoc+runCmmLint platform l p =+ case unCL (l p) platform of Left err -> Just (vcat [text "Cmm lint error:", nest 2 err, text "Program was:",- nest 2 (ppr p)])+ nest 2 (pdoc platform p)]) Right _ -> Nothing -lintCmmDecl :: DynFlags -> GenCmmDecl h i CmmGraph -> CmmLint ()-lintCmmDecl dflags (CmmProc _ lbl _ g)- = addLintInfo (text "in proc " <> ppr lbl) $ lintCmmGraph dflags g-lintCmmDecl _ (CmmData {})+lintCmmDecl :: GenCmmDecl h i CmmGraph -> CmmLint ()+lintCmmDecl (CmmProc _ lbl _ g)+ = do+ platform <- getPlatform+ addLintInfo (text "in proc " <> pdoc platform lbl) $ lintCmmGraph g+lintCmmDecl (CmmData {}) = return () -lintCmmGraph :: DynFlags -> CmmGraph -> CmmLint ()-lintCmmGraph dflags g =- cmmLocalLiveness dflags g `seq` mapM_ (lintCmmBlock labels) blocks- -- cmmLiveness throws an error if there are registers- -- live on entry to the graph (i.e. undefined- -- variables)- where- blocks = toBlockList g- labels = setFromList (map entryLabel blocks)+lintCmmGraph :: CmmGraph -> CmmLint ()+lintCmmGraph g = do+ platform <- getPlatform+ let+ blocks = toBlockList g+ labels = setFromList (map entryLabel blocks)+ cmmLocalLiveness platform g `seq` mapM_ (lintCmmBlock labels) blocks+ -- cmmLiveness throws an error if there are registers+ -- live on entry to the graph (i.e. undefined+ -- variables) lintCmmBlock :: LabelSet -> CmmBlock -> CmmLint ()@@ -188,7 +190,7 @@ if (erep `cmmEqType_ignoring_ptrhood` bWord platform) then return () else cmmLintErr (text "switch scrutinee is not a word: " <>- ppr e <> text " :: " <> ppr erep)+ pdoc platform e <> text " :: " <> ppr erep) CmmCall { cml_target = target, cml_cont = cont } -> do _ <- lintCmmExpr target@@ -222,28 +224,28 @@ -- | As noted in Note [Register parameter passing], the arguments and -- 'ForeignTarget' of a foreign call mustn't mention -- caller-saved registers.-mayNotMentionCallerSavedRegs :: (UserOfRegs GlobalReg a, Outputable a)+mayNotMentionCallerSavedRegs :: (UserOfRegs GlobalReg a, OutputableP Platform a) => SDoc -> a -> CmmLint () mayNotMentionCallerSavedRegs what thing = do- dflags <- getDynFlags- let badRegs = filter (callerSaves (targetPlatform dflags))- $ foldRegsUsed dflags (flip (:)) [] thing+ platform <- getPlatform+ let badRegs = filter (callerSaves platform)+ $ foldRegsUsed platform (flip (:)) [] thing unless (null badRegs)- $ cmmLintErr (what <+> text "mentions caller-saved registers: " <> ppr badRegs $$ ppr thing)+ $ cmmLintErr (what <+> text "mentions caller-saved registers: " <> ppr badRegs $$ pdoc platform thing) checkCond :: Platform -> CmmExpr -> CmmLint () checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return () checkCond platform (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth platform = return () -- constant values-checkCond _ expr+checkCond platform expr = cmmLintErr (hang (text "expression is not a conditional:") 2- (ppr expr))+ (pdoc platform expr)) -- ----------------------------------------------------------------------------- -- CmmLint monad -- just a basic error monad: -newtype CmmLint a = CmmLint { unCL :: DynFlags -> Either SDoc a }+newtype CmmLint a = CmmLint { unCL :: Platform -> Either SDoc a } deriving (Functor) instance Applicative CmmLint where@@ -251,37 +253,38 @@ (<*>) = ap instance Monad CmmLint where- CmmLint m >>= k = CmmLint $ \dflags ->- case m dflags of+ CmmLint m >>= k = CmmLint $ \platform ->+ case m platform of Left e -> Left e- Right a -> unCL (k a) dflags--instance HasDynFlags CmmLint where- getDynFlags = CmmLint (\dflags -> Right dflags)+ Right a -> unCL (k a) platform getPlatform :: CmmLint Platform-getPlatform = targetPlatform <$> getDynFlags+getPlatform = CmmLint $ \platform -> Right platform cmmLintErr :: SDoc -> CmmLint a cmmLintErr msg = CmmLint (\_ -> Left msg) addLintInfo :: SDoc -> CmmLint a -> CmmLint a-addLintInfo info thing = CmmLint $ \dflags ->- case unCL thing dflags of+addLintInfo info thing = CmmLint $ \platform ->+ case unCL thing platform of Left err -> Left (hang info 2 err) Right a -> Right a cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a cmmLintMachOpErr expr argsRep opExpectsRep- = cmmLintErr (text "in MachOp application: " $$- nest 2 (ppr expr) $$+ = do+ platform <- getPlatform+ cmmLintErr (text "in MachOp application: " $$+ nest 2 (pdoc platform expr) $$ (text "op is expecting: " <+> ppr opExpectsRep) $$ (text "arguments provide: " <+> ppr argsRep)) cmmLintAssignErr :: CmmNode e x -> CmmType -> CmmType -> CmmLint a cmmLintAssignErr stmt e_ty r_ty- = cmmLintErr (text "in assignment: " $$- nest 2 (vcat [ppr stmt,+ = do+ platform <- getPlatform+ cmmLintErr (text "in assignment: " $$+ nest 2 (vcat [pdoc platform stmt, text "Reg ty:" <+> ppr r_ty, text "Rhs ty:" <+> ppr e_ty]))
compiler/GHC/Cmm/Liveness.hs view
@@ -14,7 +14,7 @@ import GHC.Prelude -import GHC.Driver.Session+import GHC.Platform import GHC.Cmm.BlockId import GHC.Cmm import GHC.Cmm.Ppr.Expr () -- For Outputable instances@@ -52,17 +52,17 @@ -- | Calculated liveness info for a CmmGraph ----------------------------------------------------------------------------- -cmmLocalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness LocalReg-cmmLocalLiveness dflags graph =- check $ analyzeCmmBwd liveLattice (xferLive dflags) graph mapEmpty+cmmLocalLiveness :: Platform -> CmmGraph -> BlockEntryLiveness LocalReg+cmmLocalLiveness platform graph =+ check $ analyzeCmmBwd liveLattice (xferLive platform) graph mapEmpty where entry = g_entry graph check facts = noLiveOnEntry entry (expectJust "check" $ mapLookup entry facts) facts -cmmGlobalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness GlobalReg-cmmGlobalLiveness dflags graph =- analyzeCmmBwd liveLattice (xferLive dflags) graph mapEmpty+cmmGlobalLiveness :: Platform -> CmmGraph -> BlockEntryLiveness GlobalReg+cmmGlobalLiveness platform graph =+ analyzeCmmBwd liveLattice (xferLive platform) graph mapEmpty -- | On entry to the procedure, there had better not be any LocalReg's live-in. noLiveOnEntry :: BlockId -> CmmLive LocalReg -> a -> a@@ -72,10 +72,10 @@ gen_kill :: (DefinerOfRegs r n, UserOfRegs r n)- => DynFlags -> n -> CmmLive r -> CmmLive r-gen_kill dflags node set =- let !afterKill = foldRegsDefd dflags deleteFromRegSet set node- in foldRegsUsed dflags extendRegSet afterKill node+ => Platform -> n -> CmmLive r -> CmmLive r+gen_kill platform node set =+ let !afterKill = foldRegsDefd platform deleteFromRegSet set node+ in foldRegsUsed platform extendRegSet afterKill node {-# INLINE gen_kill #-} xferLive@@ -85,10 +85,10 @@ , UserOfRegs r (CmmNode O C) , DefinerOfRegs r (CmmNode O C) )- => DynFlags -> TransferFun (CmmLive r)-xferLive dflags (BlockCC eNode middle xNode) fBase =- let joined = gen_kill dflags xNode $! joinOutFacts liveLattice xNode fBase- !result = foldNodesBwdOO (gen_kill dflags) middle joined+ => Platform -> TransferFun (CmmLive r)+xferLive platform (BlockCC eNode middle xNode) fBase =+ let joined = gen_kill platform xNode $! joinOutFacts liveLattice xNode fBase+ !result = foldNodesBwdOO (gen_kill platform) middle joined in mapSingleton (entryLabel eNode) result-{-# SPECIALIZE xferLive :: DynFlags -> TransferFun (CmmLive LocalReg) #-}-{-# SPECIALIZE xferLive :: DynFlags -> TransferFun (CmmLive GlobalReg) #-}+{-# SPECIALIZE xferLive :: Platform -> TransferFun (CmmLive LocalReg) #-}+{-# SPECIALIZE xferLive :: Platform -> TransferFun (CmmLive GlobalReg) #-}
compiler/GHC/Cmm/Parser.y view
@@ -249,6 +249,7 @@ import GHC.Types.SrcLoc import GHC.Driver.Session import GHC.Driver.Ppr+import GHC.Driver.Config import GHC.Utils.Error import GHC.Data.StringBuffer import GHC.Data.FastString@@ -442,8 +443,9 @@ getCodeScoped $ loopDecls $ do { (entry_ret_label, info, stk_formals) <- $1; dflags <- getDynFlags;+ platform <- getPlatform; formals <- sequence (fromMaybe [] $3);- withName (showSDoc dflags (ppr entry_ret_label))+ withName (showSDoc dflags (pdoc platform entry_ret_label)) $4; return (entry_ret_label, info, stk_formals, formals) } let do_layout = isJust $3@@ -996,8 +998,8 @@ ( "i2f64", flip MO_SF_Conv W64 ) ] -callishMachOps :: UniqFM FastString ([CmmExpr] -> (CallishMachOp, [CmmExpr]))-callishMachOps = listToUFM $+callishMachOps :: Platform -> UniqFM FastString ([CmmExpr] -> (CallishMachOp, [CmmExpr]))+callishMachOps platform = listToUFM $ map (\(x, y) -> (mkFastString x, y)) [ ( "read_barrier", (MO_ReadBarrier,)), ( "write_barrier", (MO_WriteBarrier,)),@@ -1049,7 +1051,7 @@ args' = init args align = case last args of CmmLit (CmmInt alignInteger _) -> fromInteger alignInteger- e -> pgmErrorDoc "Non-constant alignment in memcpy-like function:" (ppr e)+ e -> pgmErrorDoc "Non-constant alignment in memcpy-like function:" (pdoc platform e) -- The alignment of memcpy-ish operations must be a -- compile-time constant. We verify this here, passing it around -- in the MO_* constructor. In order to do this, however, we@@ -1166,7 +1168,7 @@ let size = case constantFoldExpr platform esize of CmmLit (CmmInt n _) -> n _other -> pprPanic "CmmParse: not a compile-time integer: "- (ppr esize)+ (pdoc platform esize) let frame = old_updfr_off + platformWordSizeInBytes platform * fromIntegral size emitAssign reg (CmmStackSlot Old frame) withUpdFrameOff frame body@@ -1269,7 +1271,9 @@ -> [CmmParse CmmExpr] -> PD (CmmParse ()) primCall results_code name args_code- = case lookupUFM callishMachOps name of+ = do+ platform <- PD.getPlatform+ case lookupUFM (callishMachOps platform) name of Nothing -> failMsgPD ("unknown primitive " ++ unpackFS name) Just f -> return $ do results <- sequence results_code@@ -1429,7 +1433,8 @@ buf <- hGetStringBuffer filename let init_loc = mkRealSrcLoc (mkFastString filename) 1 1- init_state = (mkPState dflags buf init_loc) { lex_state = [0] }+ opts = initParserOpts dflags+ init_state = (initParserState opts buf init_loc) { lex_state = [0] } -- reset the lex_state: the Lexer monad leaves some stuff -- in there we don't want. case unPD cmmParse dflags init_state of
compiler/GHC/Cmm/Pipeline.hs view
@@ -45,12 +45,13 @@ cmmPipeline hsc_env srtInfo prog = withTimingSilent dflags (text "Cmm pipeline") forceRes $ do let dflags = hsc_dflags hsc_env+ platform = targetPlatform dflags tops <- {-# SCC "tops" #-} mapM (cpsTop dflags) prog let (procs, data_) = partitionEithers tops (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags srtInfo procs data_- dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (ppr cmms)+ dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (pdoc platform cmms) return (srtInfo, cmms) @@ -86,7 +87,7 @@ ----------- Implement switches ------------------------------------------ g <- {-# SCC "createSwitchPlans" #-}- runUniqSM $ cmmImplementSwitchPlans dflags g+ runUniqSM $ cmmImplementSwitchPlans (backend dflags) platform g dump Opt_D_dump_cmm_switch "Post switch plan" g ----------- Proc points -------------------------------------------------@@ -97,9 +98,9 @@ if splitting_proc_points then do pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $- minimalProcPointSet (targetPlatform dflags) call_pps g+ minimalProcPointSet platform call_pps g dumpWith dflags Opt_D_dump_cmm_proc "Proc points"- FormatCMM (ppr l $$ ppr pp $$ ppr g)+ FormatCMM (pdoc platform l $$ ppr pp $$ pdoc platform g) return pp else return call_pps@@ -114,12 +115,12 @@ ----------- Sink and inline assignments -------------------------------- g <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout]- condPass Opt_CmmSink (cmmSink dflags) g+ condPass Opt_CmmSink (cmmSink platform) g Opt_D_dump_cmm_sink "Sink assignments" ------------- CAF analysis ---------------------------------------------- let cafEnv = {-# SCC "cafAnal" #-} cafAnal platform call_pps l g- dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" FormatText (ppr cafEnv)+ dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" FormatText (pdoc platform cafEnv) g <- if splitting_proc_points then do@@ -129,7 +130,7 @@ dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map" FormatCMM (ppr pp_map) g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $- splitAtProcPoints dflags l call_pps proc_points pp_map+ splitAtProcPoints platform l call_pps proc_points pp_map (CmmProc h l v g) dumps Opt_D_dump_cmm_split "Post splitting" g return g@@ -157,7 +158,7 @@ dump = dumpGraph dflags dumps flag name- = mapM_ (dumpWith dflags flag name FormatCMM . ppr)+ = mapM_ (dumpWith dflags flag name FormatCMM . pdoc platform) condPass flag pass g dumpflag dumpname = if gopt flag dflags@@ -353,9 +354,10 @@ dumpGraph :: DynFlags -> DumpFlag -> String -> CmmGraph -> IO () dumpGraph dflags flag name g = do when (gopt Opt_DoCmmLinting dflags) $ do_lint g- dumpWith dflags flag name FormatCMM (ppr g)+ dumpWith dflags flag name FormatCMM (pdoc platform g) where- do_lint g = case cmmLintGraph dflags g of+ platform = targetPlatform dflags+ do_lint g = case cmmLintGraph platform g of Just err -> do { fatalErrorMsg dflags err ; ghcExit dflags 1 }
compiler/GHC/Cmm/Ppr.hs view
@@ -1,5 +1,10 @@-{-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-}+ {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------@@ -43,7 +48,6 @@ import GHC.Prelude hiding (succ) import GHC.Platform-import GHC.Driver.Session (targetPlatform) import GHC.Cmm.CLabel import GHC.Cmm import GHC.Cmm.Utils@@ -64,13 +68,12 @@ instance Outputable CmmStackInfo where ppr = pprStackInfo -instance Outputable CmmTopInfo where- ppr = pprTopInfo+instance OutputableP Platform CmmTopInfo where+ pdoc = pprTopInfo -instance Outputable (CmmNode e x) where- ppr e = sdocWithDynFlags $ \dflags ->- pprNode (targetPlatform dflags) e+instance OutputableP Platform (CmmNode e x) where+ pdoc = pprNode instance Outputable Convention where ppr = pprConvention@@ -78,26 +81,26 @@ instance Outputable ForeignConvention where ppr = pprForeignConvention -instance Outputable ForeignTarget where- ppr = pprForeignTarget+instance OutputableP Platform ForeignTarget where+ pdoc = pprForeignTarget instance Outputable CmmReturnInfo where ppr = pprReturnInfo -instance Outputable (Block CmmNode C C) where- ppr = pprBlock-instance Outputable (Block CmmNode C O) where- ppr = pprBlock-instance Outputable (Block CmmNode O C) where- ppr = pprBlock-instance Outputable (Block CmmNode O O) where- ppr = pprBlock+instance OutputableP Platform (Block CmmNode C C) where+ pdoc = pprBlock+instance OutputableP Platform (Block CmmNode C O) where+ pdoc = pprBlock+instance OutputableP Platform (Block CmmNode O C) where+ pdoc = pprBlock+instance OutputableP Platform (Block CmmNode O O) where+ pdoc = pprBlock -instance Outputable (Graph CmmNode e x) where- ppr = pprGraph+instance OutputableP Platform (Graph CmmNode e x) where+ pdoc = pprGraph -instance Outputable CmmGraph where- ppr = pprCmmGraph+instance OutputableP Platform CmmGraph where+ pdoc = pprCmmGraph ---------------------------------------------------------- -- Outputting types Cmm contains@@ -106,40 +109,41 @@ pprStackInfo (StackInfo {arg_space=arg_space}) = text "arg_space: " <> ppr arg_space -pprTopInfo :: CmmTopInfo -> SDoc-pprTopInfo (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) =- vcat [text "info_tbls: " <> ppr info_tbl,+pprTopInfo :: Platform -> CmmTopInfo -> SDoc+pprTopInfo platform (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) =+ vcat [text "info_tbls: " <> pdoc platform info_tbl, text "stack_info: " <> ppr stack_info] ---------------------------------------------------------- -- Outputting blocks and graphs pprBlock :: IndexedCO x SDoc SDoc ~ SDoc- => Block CmmNode e x -> IndexedCO e SDoc SDoc-pprBlock block- = foldBlockNodesB3 ( ($$) . ppr- , ($$) . (nest 4) . ppr- , ($$) . (nest 4) . ppr+ => Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc+pprBlock platform block+ = foldBlockNodesB3 ( ($$) . pdoc platform+ , ($$) . (nest 4) . pdoc platform+ , ($$) . (nest 4) . pdoc platform ) block empty -pprGraph :: Graph CmmNode e x -> SDoc-pprGraph GNil = empty-pprGraph (GUnit block) = ppr block-pprGraph (GMany entry body exit)- = text "{"- $$ nest 2 (pprMaybeO entry $$ (vcat $ map ppr $ bodyToBlockList body) $$ pprMaybeO exit)- $$ text "}"- where pprMaybeO :: Outputable (Block CmmNode e x)- => MaybeO ex (Block CmmNode e x) -> SDoc- pprMaybeO NothingO = empty- pprMaybeO (JustO block) = ppr block+pprGraph :: Platform -> Graph CmmNode e x -> SDoc+pprGraph platform = \case+ GNil -> empty+ GUnit block -> pdoc platform block+ GMany entry body exit ->+ text "{"+ $$ nest 2 (pprMaybeO entry $$ (vcat $ map (pdoc platform) $ bodyToBlockList body) $$ pprMaybeO exit)+ $$ text "}"+ where pprMaybeO :: OutputableP Platform (Block CmmNode e x)+ => MaybeO ex (Block CmmNode e x) -> SDoc+ pprMaybeO NothingO = empty+ pprMaybeO (JustO block) = pdoc platform block -pprCmmGraph :: CmmGraph -> SDoc-pprCmmGraph g+pprCmmGraph :: Platform -> CmmGraph -> SDoc+pprCmmGraph platform g = text "{" <> text "offset"- $$ nest 2 (vcat $ map ppr blocks)+ $$ nest 2 (vcat $ map (pdoc platform) blocks) $$ text "}" where blocks = revPostorder g -- revPostorder has the side-effect of discarding unreachable code,@@ -164,17 +168,17 @@ pprReturnInfo CmmMayReturn = empty pprReturnInfo CmmNeverReturns = text "never returns" -pprForeignTarget :: ForeignTarget -> SDoc-pprForeignTarget (ForeignTarget fn c) = ppr c <+> ppr_target fn+pprForeignTarget :: Platform -> ForeignTarget -> SDoc+pprForeignTarget platform (ForeignTarget fn c) = ppr c <+> ppr_target fn where ppr_target :: CmmExpr -> SDoc- ppr_target t@(CmmLit _) = ppr t- ppr_target fn' = parens (ppr fn')+ ppr_target t@(CmmLit _) = pdoc platform t+ ppr_target fn' = parens (pdoc platform fn') -pprForeignTarget (PrimTarget op)+pprForeignTarget platform (PrimTarget op) -- HACK: We're just using a ForeignLabel to get this printed, the label -- might not really be foreign.- = ppr+ = pdoc platform (CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing ForeignLabelInThisPackage IsFunction))@@ -203,13 +207,13 @@ -- unwind reg = expr; CmmUnwind regs -> text "unwind "- <> commafy (map (\(r,e) -> ppr r <+> char '=' <+> ppr e) regs) <> semi+ <> commafy (map (\(r,e) -> ppr r <+> char '=' <+> pdoc platform e) regs) <> semi -- reg = expr;- CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi+ CmmAssign reg expr -> ppr reg <+> equals <+> pdoc platform expr <> semi -- rep[lv] = expr;- CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi+ CmmStore lv expr -> rep <> brackets (pdoc platform lv) <+> equals <+> pdoc platform expr <> semi where rep = ppr ( cmmExprType platform expr ) @@ -219,7 +223,7 @@ hsep [ ppUnless (null results) $ parens (commafy $ map ppr results) <+> equals, text "call",- ppr target <> parens (commafy $ map ppr args) <> semi]+ pdoc platform target <> parens (commafy $ map (pdoc platform) args) <> semi] -- goto label; CmmBranch ident -> text "goto" <+> ppr ident <> semi@@ -227,7 +231,7 @@ -- if (expr) goto t; else goto f; CmmCondBranch expr t f l -> hsep [ text "if"- , parens(ppr expr)+ , parens (pdoc platform expr) , case l of Nothing -> empty Just b -> parens (text "likely:" <+> ppr b)@@ -241,8 +245,8 @@ hang (hsep [ text "switch" , range , if isTrivialCmmExpr expr- then ppr expr- else parens (ppr expr)+ then pdoc platform expr+ else parens (pdoc platform expr) , text "{" ]) 4 (vcat (map ppCase cases) $$ def) $$ rbrace@@ -271,8 +275,8 @@ text "res: " <> ppr res <> comma <+> text "upd: " <> ppr updfr_off , semi ]- where pprFun f@(CmmLit _) = ppr f- pprFun f = parens (ppr f)+ where pprFun f@(CmmLit _) = pdoc platform f+ pprFun f = parens (pdoc platform f) returns | Just r <- k = text "returns to" <+> ppr r <> comma@@ -281,9 +285,9 @@ CmmForeignCall {tgt=t, res=rs, args=as, succ=s, ret_args=a, ret_off=u, intrbl=i} -> hcat $ if i then [text "interruptible", space] else [] ++ [ text "foreign call", space- , ppr t, text "(...)", space+ , pdoc platform t, text "(...)", space , text "returns to" <+> ppr s- <+> text "args:" <+> parens (ppr as)+ <+> text "args:" <+> parens (pdoc platform as) <+> text "ress:" <+> parens (ppr rs) , text "ret_args:" <+> ppr a , text "ret_off:" <+> ppr u
compiler/GHC/Cmm/Ppr/Decl.hs view
@@ -1,5 +1,9 @@ {-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-} + ---------------------------------------------------------------------------- -- -- Pretty-printing of common Cmm types@@ -36,7 +40,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module GHC.Cmm.Ppr.Decl- ( writeCmms, pprCmms, pprCmmGroup, pprSection, pprStatic+ ( pprCmms, pprCmmGroup, pprSection, pprStatic ) where @@ -46,62 +50,54 @@ import GHC.Cmm.Ppr.Expr import GHC.Cmm -import GHC.Driver.Ppr-import GHC.Driver.Session import GHC.Utils.Outputable import GHC.Data.FastString import Data.List-import System.IO import qualified Data.ByteString as BS -pprCmms :: (Outputable info, Outputable g)- => [GenCmmGroup RawCmmStatics info g] -> SDoc-pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))+pprCmms :: (OutputableP Platform info, OutputableP Platform g)+ => Platform -> [GenCmmGroup RawCmmStatics info g] -> SDoc+pprCmms platform cmms = pprCode CStyle (vcat (intersperse separator $ map (pdoc platform) cmms)) where separator = space $$ text "-------------------" $$ space -writeCmms :: (Outputable info, Outputable g)- => DynFlags -> Handle -> [GenCmmGroup RawCmmStatics info g] -> IO ()-writeCmms dflags handle cmms = printForC dflags handle (pprCmms cmms)- ----------------------------------------------------------------------------- -instance (Outputable d, Outputable info, Outputable i)- => Outputable (GenCmmDecl d info i) where- ppr t = pprTop t+instance (OutputableP Platform d, OutputableP Platform info, OutputableP Platform i)+ => OutputableP Platform (GenCmmDecl d info i) where+ pdoc = pprTop -instance Outputable (GenCmmStatics a) where- ppr = pprStatics+instance OutputableP Platform (GenCmmStatics a) where+ pdoc = pprStatics -instance Outputable CmmStatic where- ppr e = sdocWithDynFlags $ \dflags ->- pprStatic (targetPlatform dflags) e+instance OutputableP Platform CmmStatic where+ pdoc = pprStatic -instance Outputable CmmInfoTable where- ppr = pprInfoTable+instance OutputableP Platform CmmInfoTable where+ pdoc = pprInfoTable ----------------------------------------------------------------------------- -pprCmmGroup :: (Outputable d, Outputable info, Outputable g)- => GenCmmGroup d info g -> SDoc-pprCmmGroup tops- = vcat $ intersperse blankLine $ map pprTop tops+pprCmmGroup :: (OutputableP Platform d, OutputableP Platform info, OutputableP Platform g)+ => Platform -> GenCmmGroup d info g -> SDoc+pprCmmGroup platform tops+ = vcat $ intersperse blankLine $ map (pprTop platform) tops -- -------------------------------------------------------------------------- -- Top level `procedure' blocks. ---pprTop :: (Outputable d, Outputable info, Outputable i)- => GenCmmDecl d info i -> SDoc+pprTop :: (OutputableP Platform d, OutputableP Platform info, OutputableP Platform i)+ => Platform -> GenCmmDecl d info i -> SDoc -pprTop (CmmProc info lbl live graph)+pprTop platform (CmmProc info lbl live graph) - = vcat [ ppr lbl <> lparen <> rparen <+> lbrace <+> text "// " <+> ppr live- , nest 8 $ lbrace <+> ppr info $$ rbrace- , nest 4 $ ppr graph+ = vcat [ pdoc platform lbl <> lparen <> rparen <+> lbrace <+> text "// " <+> ppr live+ , nest 8 $ lbrace <+> pdoc platform info $$ rbrace+ , nest 4 $ pdoc platform graph , rbrace ] -- --------------------------------------------------------------------------@@ -109,25 +105,25 @@ -- -- section "data" { ... } ---pprTop (CmmData section ds) =- (hang (pprSection section <+> lbrace) 4 (ppr ds))+pprTop platform (CmmData section ds) =+ (hang (pprSection platform section <+> lbrace) 4 (pdoc platform ds)) $$ rbrace -- -------------------------------------------------------------------------- -- Info tables. -pprInfoTable :: CmmInfoTable -> SDoc-pprInfoTable (CmmInfoTable { cit_lbl = lbl, cit_rep = rep+pprInfoTable :: Platform -> CmmInfoTable -> SDoc+pprInfoTable platform (CmmInfoTable { cit_lbl = lbl, cit_rep = rep , cit_prof = prof_info , cit_srt = srt })- = vcat [ text "label: " <> ppr lbl+ = vcat [ text "label: " <> pdoc platform lbl , text "rep: " <> ppr rep , case prof_info of NoProfilingInfo -> empty ProfilingInfo ct cd -> vcat [ text "type: " <> text (show (BS.unpack ct)) , text "desc: " <> text (show (BS.unpack cd)) ]- , text "srt: " <> ppr srt ]+ , text "srt: " <> pdoc platform srt ] instance Outputable ForeignHint where ppr NoHint = empty@@ -142,10 +138,10 @@ -- following C-- -- -pprStatics :: GenCmmStatics a -> SDoc-pprStatics (CmmStatics lbl itbl ccs payload) =- ppr lbl <> colon <+> ppr itbl <+> ppr ccs <+> ppr payload-pprStatics (CmmStaticsRaw lbl ds) = vcat ((ppr lbl <> colon) : map ppr ds)+pprStatics :: Platform -> GenCmmStatics a -> SDoc+pprStatics platform (CmmStatics lbl itbl ccs payload) =+ pdoc platform lbl <> colon <+> pdoc platform itbl <+> ppr ccs <+> pdoc platform payload+pprStatics platform (CmmStaticsRaw lbl ds) = vcat ((pdoc platform lbl <> colon) : map (pprStatic platform) ds) pprStatic :: Platform -> CmmStatic -> SDoc pprStatic platform s = case s of@@ -157,9 +153,9 @@ -- -------------------------------------------------------------------------- -- data sections ---pprSection :: Section -> SDoc-pprSection (Section t suffix) =- section <+> doubleQuotes (pprSectionType t <+> char '.' <+> ppr suffix)+pprSection :: Platform -> Section -> SDoc+pprSection platform (Section t suffix) =+ section <+> doubleQuotes (pprSectionType t <+> char '.' <+> pdoc platform suffix) where section = text "section"
compiler/GHC/Cmm/Ppr/Expr.hs view
@@ -32,6 +32,9 @@ -- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs -- {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+ {-# OPTIONS_GHC -fno-warn-orphans #-} module GHC.Cmm.Ppr.Expr@@ -41,7 +44,6 @@ import GHC.Prelude -import GHC.Driver.Session (targetPlatform) import GHC.Driver.Ppr import GHC.Platform@@ -54,16 +56,14 @@ ----------------------------------------------------------------------------- -instance Outputable CmmExpr where- ppr e = sdocWithDynFlags $ \dflags ->- pprExpr (targetPlatform dflags) e+instance OutputableP Platform CmmExpr where+ pdoc = pprExpr instance Outputable CmmReg where ppr e = pprReg e -instance Outputable CmmLit where- ppr l = sdocWithDynFlags $ \dflags ->- pprLit (targetPlatform dflags) l+instance OutputableP Platform CmmLit where+ pdoc = pprLit instance Outputable LocalReg where ppr e = pprLocalReg e@@ -74,6 +74,9 @@ instance Outputable GlobalReg where ppr e = pprGlobalReg e +instance OutputableP env GlobalReg where+ pdoc _ = ppr+ -- -------------------------------------------------------------------------- -- Expressions --@@ -147,7 +150,7 @@ pprExpr9 platform e = case e of CmmLit lit -> pprLit1 platform lit- CmmLoad expr rep -> ppr rep <> brackets (ppr expr)+ CmmLoad expr rep -> ppr rep <> brackets (pdoc platform expr) CmmReg reg -> ppr reg CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off) CmmStackSlot a off -> parens (ppr a <+> char '+' <+> int off)@@ -204,10 +207,10 @@ CmmFloat f rep -> hsep [ double (fromRat f), dcolon, ppr rep ] CmmVec lits -> char '<' <> commafy (map (pprLit platform) lits) <> char '>'- CmmLabel clbl -> ppr clbl- CmmLabelOff clbl i -> ppr clbl <> ppr_offset i- CmmLabelDiffOff clbl1 clbl2 i _ -> ppr clbl1 <> char '-'- <> ppr clbl2 <> ppr_offset i+ CmmLabel clbl -> pdoc platform clbl+ CmmLabelOff clbl i -> pdoc platform clbl <> ppr_offset i+ CmmLabelDiffOff clbl1 clbl2 i _ -> pdoc platform clbl1 <> char '-'+ <> pdoc platform clbl2 <> ppr_offset i CmmBlock id -> ppr id CmmHighStackMark -> text "<highSp>"
compiler/GHC/Cmm/ProcPoint.hs view
@@ -11,7 +11,6 @@ import GHC.Prelude hiding (last, unzip, succ, zip) -import GHC.Driver.Session import GHC.Cmm.BlockId import GHC.Cmm.CLabel import GHC.Cmm@@ -207,7 +206,7 @@ newPoint = listToMaybe newPoints ppSuccessor b = let nreached id = case mapLookup id env `orElse`- pprPanic "no ppt" (ppr id <+> ppr b) of+ pprPanic "no ppt" (ppr id <+> pdoc platform b) of ProcPoint -> 1 ReachedBy ps -> setSize ps block_procpoints = nreached (entryLabel b)@@ -238,9 +237,9 @@ -- Input invariant: A block should only be reachable from a single ProcPoint. -- ToDo: use the _ret naming convention that the old code generator -- used. -- EZY-splitAtProcPoints :: DynFlags -> CLabel -> ProcPointSet-> ProcPointSet -> LabelMap Status ->+splitAtProcPoints :: Platform -> CLabel -> ProcPointSet-> ProcPointSet -> LabelMap Status -> CmmDecl -> UniqSM [CmmDecl]-splitAtProcPoints dflags entry_label callPPs procPoints procMap+splitAtProcPoints platform entry_label callPPs procPoints procMap (CmmProc (TopInfo {info_tbls = info_tbls}) top_l _ g@(CmmGraph {g_entry=entry})) = do -- Build a map from procpoints to the blocks they reach@@ -262,7 +261,7 @@ where graph = mapLookup procId graphEnv `orElse` mapEmpty graph' = mapInsert bid b graph - let liveness = cmmGlobalLiveness dflags g+ let liveness = cmmGlobalLiveness platform g let ppLiveness pp = filter isArgReg $ regSetToList $ expectJust "ppLiveness" $ mapLookup pp liveness@@ -316,7 +315,6 @@ -- when jumping to a PP that has an info table, if -- tablesNextToCode is off we must jump to the entry -- label instead.- platform = targetPlatform dflags tablesNextToCode = platformTablesNextToCode platform jump_label (Just info_lbl) _ | tablesNextToCode = info_lbl
compiler/GHC/Cmm/Sink.hs view
@@ -16,7 +16,6 @@ import GHC.Platform.Regs import GHC.Platform-import GHC.Driver.Session import GHC.Types.Unique import GHC.Types.Unique.FM @@ -165,10 +164,10 @@ -- y = e2 -- x = e1 -cmmSink :: DynFlags -> CmmGraph -> CmmGraph-cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks+cmmSink :: Platform -> CmmGraph -> CmmGraph+cmmSink platform graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks where- liveness = cmmLocalLiveness dflags graph+ liveness = cmmLocalLiveness platform graph getLive l = mapFindWithDefault Set.empty l liveness blocks = revPostorder graph@@ -181,7 +180,6 @@ -- pprTrace "sink" (ppr lbl) $ blockJoin first final_middle final_last : sink sunk' bs where- platform = targetPlatform dflags lbl = entryLabel b (first, middle, last) = blockSplit b @@ -191,13 +189,13 @@ -- the node. This will help us decide whether we can inline -- an assignment in the current node or not. live = Set.unions (map getLive succs)- live_middle = gen_kill dflags last live- ann_middles = annotate dflags live_middle (blockToList middle)+ live_middle = gen_kill platform last live+ ann_middles = annotate platform live_middle (blockToList middle) -- Now sink and inline in this block- (middle', assigs) = walk dflags ann_middles (mapFindWithDefault [] lbl sunk)+ (middle', assigs) = walk platform ann_middles (mapFindWithDefault [] lbl sunk) fold_last = constantFoldNode platform last- (final_last, assigs') = tryToInline dflags live fold_last assigs+ (final_last, assigs') = tryToInline platform live fold_last assigs -- We cannot sink into join points (successors with more than -- one predecessor), so identify the join points and the set@@ -217,12 +215,12 @@ _ -> False -- Now, drop any assignments that we will not sink any further.- (dropped_last, assigs'') = dropAssignments dflags drop_if init_live_sets assigs'+ (dropped_last, assigs'') = dropAssignments platform drop_if init_live_sets assigs' drop_if a@(r,rhs,_) live_sets = (should_drop, live_sets') where- should_drop = conflicts dflags a final_last- || not (isTrivial dflags rhs) && live_in_multi live_sets r+ should_drop = conflicts platform a final_last+ || not (isTrivial platform rhs) && live_in_multi live_sets r || r `Set.member` live_in_joins live_sets' | should_drop = live_sets@@ -231,12 +229,12 @@ upd set | r `Set.member` set = set `Set.union` live_rhs | otherwise = set - live_rhs = foldRegsUsed dflags extendRegSet emptyRegSet rhs+ live_rhs = foldRegsUsed platform extendRegSet emptyRegSet rhs final_middle = foldl' blockSnoc middle' dropped_last sunk' = mapUnion sunk $- mapFromList [ (l, filterAssignments dflags (getLive l) assigs'')+ mapFromList [ (l, filterAssignments platform (getLive l) assigs'') | l <- succs ] {- TODO: enable this later, when we have some good tests in place to@@ -255,12 +253,12 @@ -- We allow duplication of trivial expressions: registers (both local and -- global) and literals. ---isTrivial :: DynFlags -> CmmExpr -> Bool+isTrivial :: Platform -> CmmExpr -> Bool isTrivial _ (CmmReg (CmmLocal _)) = True-isTrivial dflags (CmmReg (CmmGlobal r)) = -- see Note [Inline GlobalRegs?]- if isARM (platformArch (targetPlatform dflags))+isTrivial platform (CmmReg (CmmGlobal r)) = -- see Note [Inline GlobalRegs?]+ if isARM (platformArch platform) then True -- CodeGen.Platform.ARM does not have globalRegMaybe- else isJust (globalRegMaybe (targetPlatform dflags) r)+ else isJust (globalRegMaybe platform r) -- GlobalRegs that are loads from BaseReg are not trivial isTrivial _ (CmmLit _) = True isTrivial _ _ = False@@ -268,9 +266,9 @@ -- -- annotate each node with the set of registers live *after* the node ---annotate :: DynFlags -> LocalRegSet -> [CmmNode O O] -> [(LocalRegSet, CmmNode O O)]-annotate dflags live nodes = snd $ foldr ann (live,[]) nodes- where ann n (live,nodes) = (gen_kill dflags n live, (live,n) : nodes)+annotate :: Platform -> LocalRegSet -> [CmmNode O O] -> [(LocalRegSet, CmmNode O O)]+annotate platform live nodes = snd $ foldr ann (live,[]) nodes+ where ann n (live,nodes) = (gen_kill platform n live, (live,n) : nodes) -- -- Find the blocks that have multiple successors (join points)@@ -287,14 +285,14 @@ -- filter the list of assignments to remove any assignments that -- are not live in a continuation. ---filterAssignments :: DynFlags -> LocalRegSet -> Assignments -> Assignments-filterAssignments dflags live assigs = reverse (go assigs [])+filterAssignments :: Platform -> LocalRegSet -> Assignments -> Assignments+filterAssignments platform live assigs = reverse (go assigs []) where go [] kept = kept go (a@(r,_,_):as) kept | needed = go as (a:kept) | otherwise = go as kept where needed = r `Set.member` live- || any (conflicts dflags a) (map toNode kept)+ || any (conflicts platform a) (map toNode kept) -- Note that we must keep assignments that are -- referred to by other assignments we have -- already kept.@@ -313,7 +311,7 @@ -- * a list of assignments that will be placed *after* that block. -- -walk :: DynFlags+walk :: Platform -> [(LocalRegSet, CmmNode O O)] -- nodes of the block, annotated with -- the set of registers live *after* -- this node.@@ -327,7 +325,7 @@ , Assignments -- Assignments to sink further ) -walk dflags nodes assigs = go nodes emptyBlock assigs+walk platform nodes assigs = go nodes emptyBlock assigs where go [] block as = (block, as) go ((live,node):ns) block as@@ -336,13 +334,12 @@ | Just a <- shouldSink platform node2 = go ns block (a : as1) | otherwise = go ns block' as' where- platform = targetPlatform dflags node1 = constantFoldNode platform node - (node2, as1) = tryToInline dflags live node1 as+ (node2, as1) = tryToInline platform live node1 as - (dropped, as') = dropAssignmentsSimple dflags- (\a -> conflicts dflags a node2) as1+ (dropped, as') = dropAssignmentsSimple platform+ (\a -> conflicts platform a node2) as1 block' = foldl' blockSnoc block dropped `blockSnoc` node2 @@ -380,13 +377,13 @@ toNode :: Assignment -> CmmNode O O toNode (r,rhs,_) = CmmAssign (CmmLocal r) rhs -dropAssignmentsSimple :: DynFlags -> (Assignment -> Bool) -> Assignments+dropAssignmentsSimple :: Platform -> (Assignment -> Bool) -> Assignments -> ([CmmNode O O], Assignments)-dropAssignmentsSimple dflags f = dropAssignments dflags (\a _ -> (f a, ())) ()+dropAssignmentsSimple platform f = dropAssignments platform (\a _ -> (f a, ())) () -dropAssignments :: DynFlags -> (Assignment -> s -> (Bool, s)) -> s -> Assignments+dropAssignments :: Platform -> (Assignment -> s -> (Bool, s)) -> s -> Assignments -> ([CmmNode O O], Assignments)-dropAssignments dflags should_drop state assigs+dropAssignments platform should_drop state assigs = (dropped, reverse kept) where (dropped,kept) = go state assigs [] []@@ -397,7 +394,7 @@ | otherwise = go state' rest dropped (assig:kept) where (dropit, state') = should_drop assig state- conflict = dropit || any (conflicts dflags assig) dropped+ conflict = dropit || any (conflicts platform assig) dropped -- -----------------------------------------------------------------------------@@ -406,7 +403,7 @@ -- inlining opens up opportunities for doing so. tryToInline- :: DynFlags+ :: Platform -> LocalRegSet -- set of registers live after this -- node. We cannot inline anything -- that is live after the node, unless@@ -418,10 +415,10 @@ , Assignments -- Remaining assignments ) -tryToInline dflags live node assigs = go usages node emptyLRegSet assigs+tryToInline platform live node assigs = go usages node emptyLRegSet assigs where usages :: UniqFM LocalReg Int -- Maps each LocalReg to a count of how often it is used- usages = foldLocalRegsUsed dflags addUsage emptyUFM node+ usages = foldLocalRegsUsed platform addUsage emptyUFM node go _usages node _skipped [] = (node, []) @@ -429,12 +426,11 @@ | cannot_inline = dont_inline | occurs_none = discard -- Note [discard during inlining] | occurs_once = inline_and_discard- | isTrivial dflags rhs = inline_and_keep+ | isTrivial platform rhs = inline_and_keep | otherwise = dont_inline where- platform = targetPlatform dflags inline_and_discard = go usages' inl_node skipped rest- where usages' = foldLocalRegsUsed dflags addUsage usages rhs+ where usages' = foldLocalRegsUsed platform addUsage usages rhs discard = go usages node skipped rest @@ -443,7 +439,7 @@ keep node' = (final_node, a : rest') where (final_node, rest') = go usages' node' (insertLRegSet l skipped) rest- usages' = foldLocalRegsUsed dflags (\m r -> addToUFM m r 2)+ usages' = foldLocalRegsUsed platform (\m r -> addToUFM m r 2) usages rhs -- we must not inline anything that is mentioned in the RHS -- of a binding that we have already skipped, so we set the@@ -451,7 +447,7 @@ cannot_inline = skipped `regsUsedIn` rhs -- Note [dependent assignments] || l `elemLRegSet` skipped- || not (okToInline dflags rhs node)+ || not (okToInline platform rhs node) l_usages = lookupUFM usages l l_live = l `elemRegSet` live@@ -569,25 +565,25 @@ -- ought to be able to handle it properly, but currently neither PprC -- nor the NCG can do it. See Note [Register parameter passing] -- See also GHC.StgToCmm.Foreign.load_args_into_temps.-okToInline :: DynFlags -> CmmExpr -> CmmNode e x -> Bool-okToInline dflags expr node@(CmmUnsafeForeignCall{}) =- not (globalRegistersConflict dflags expr node)+okToInline :: Platform -> CmmExpr -> CmmNode e x -> Bool+okToInline platform expr node@(CmmUnsafeForeignCall{}) =+ not (globalRegistersConflict platform expr node) okToInline _ _ _ = True -- ----------------------------------------------------------------------------- -- | @conflicts (r,e) node@ is @False@ if and only if the assignment -- @r = e@ can be safely commuted past statement @node@.-conflicts :: DynFlags -> Assignment -> CmmNode O x -> Bool-conflicts dflags (r, rhs, addr) node+conflicts :: Platform -> Assignment -> CmmNode O x -> Bool+conflicts platform (r, rhs, addr) node -- (1) node defines registers used by rhs of assignment. This catches -- assignments and all three kinds of calls. See Note [Sinking and calls]- | globalRegistersConflict dflags rhs node = True- | localRegistersConflict dflags rhs node = True+ | globalRegistersConflict platform rhs node = True+ | localRegistersConflict platform rhs node = True -- (2) node uses register defined by assignment- | foldRegsUsed dflags (\b r' -> r == r' || b) False node = True+ | foldRegsUsed platform (\b r' -> r == r' || b) False node = True -- (3) a store to an address conflicts with a read of the same memory | CmmStore addr' e <- node@@ -606,21 +602,19 @@ -- (7) otherwise, no conflict | otherwise = False- where- platform = targetPlatform dflags -- Returns True if node defines any global registers that are used in the -- Cmm expression-globalRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool-globalRegistersConflict dflags expr node =- foldRegsDefd dflags (\b r -> b || regUsedIn (targetPlatform dflags) (CmmGlobal r) expr)+globalRegistersConflict :: Platform -> CmmExpr -> CmmNode e x -> Bool+globalRegistersConflict platform expr node =+ foldRegsDefd platform (\b r -> b || regUsedIn platform (CmmGlobal r) expr) False node -- Returns True if node defines any local registers that are used in the -- Cmm expression-localRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool-localRegistersConflict dflags expr node =- foldRegsDefd dflags (\b r -> b || regUsedIn (targetPlatform dflags) (CmmLocal r) expr)+localRegistersConflict :: Platform -> CmmExpr -> CmmNode e x -> Bool+localRegistersConflict platform expr node =+ foldRegsDefd platform (\b r -> b || regUsedIn platform (CmmLocal r) expr) False node -- Note [Sinking and calls]
compiler/GHC/Cmm/Switch/Implement.hs view
@@ -6,6 +6,7 @@ import GHC.Prelude +import GHC.Driver.Backend import GHC.Platform import GHC.Cmm.Dataflow.Block import GHC.Cmm.BlockId@@ -13,7 +14,6 @@ import GHC.Cmm.Utils import GHC.Cmm.Switch import GHC.Types.Unique.Supply-import GHC.Driver.Session import GHC.Utils.Monad (concatMapM) --@@ -32,12 +32,12 @@ -- | Traverses the 'CmmGraph', making sure that 'CmmSwitch' are suitable for -- code generation.-cmmImplementSwitchPlans :: DynFlags -> CmmGraph -> UniqSM CmmGraph-cmmImplementSwitchPlans dflags g+cmmImplementSwitchPlans :: Backend -> Platform -> CmmGraph -> UniqSM CmmGraph+cmmImplementSwitchPlans backend platform g -- Switch generation done by backend (LLVM/C)- | backendSupportsSwitch (backend dflags) = return g+ | backendSupportsSwitch backend = return g | otherwise = do- blocks' <- concatMapM (visitSwitches (targetPlatform dflags)) (toBlockList g)+ blocks' <- concatMapM (visitSwitches platform) (toBlockList g) return $ ofBlockList (g_entry g) blocks' visitSwitches :: Platform -> CmmBlock -> UniqSM [CmmBlock]
compiler/GHC/CmmToAsm.hs view
@@ -7,7 +7,11 @@ {-# LANGUAGE BangPatterns, CPP, GADTs, ScopedTypeVariables, PatternSynonyms, DeriveFunctor #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-} + #if !defined(GHC_LOADED_INTO_GHCI) {-# LANGUAGE UnboxedTuples #-} #endif@@ -150,7 +154,7 @@ nativeCodeGen dflags this_mod modLoc h us cmms = let config = initNCGConfig dflags platform = ncgPlatform config- nCG' :: ( Outputable statics, Outputable jumpDest, Instruction instr)+ nCG' :: ( OutputableP Platform statics, Outputable jumpDest, Instruction instr) => NcgImpl statics instr jumpDest -> IO a nCG' ncgImpl = nativeCodeGen' dflags config this_mod modLoc ncgImpl h us cmms in case platformArch platform of@@ -214,7 +218,7 @@ See also Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock". -} -nativeCodeGen' :: (Outputable statics, Outputable jumpDest, Instruction instr)+nativeCodeGen' :: (OutputableP Platform statics, Outputable jumpDest, Instruction instr) => DynFlags -> NCGConfig -> Module -> ModLocation@@ -293,7 +297,7 @@ (dumpOptionsFromFlag Opt_D_dump_asm_stats) "NCG stats" FormatText -cmmNativeGenStream :: (Outputable statics, Outputable jumpDest, Instruction instr)+cmmNativeGenStream :: (OutputableP Platform statics, Outputable jumpDest, Instruction instr) => DynFlags -> NCGConfig -> Module -> ModLocation@@ -332,9 +336,10 @@ -- Link native code information into debug blocks -- See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock". let !ldbgs = cmmDebugLink (ngs_labels ngs') (ngs_unwinds ngs') ndbgs+ platform = targetPlatform dflags unless (null ldbgs) $ dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos" FormatText- (vcat $ map ppr ldbgs)+ (vcat $ map (pdoc platform) ldbgs) -- Accumulate debug information for emission in finishNativeGen. let ngs'' = ngs' { ngs_debug = ngs_debug ngs' ++ ldbgs, ngs_labels = [] }@@ -348,7 +353,7 @@ -- | Do native code generation on all these cmms. -- cmmNativeGens :: forall statics instr jumpDest.- (Outputable statics, Outputable jumpDest, Instruction instr)+ (OutputableP Platform statics, Outputable jumpDest, Instruction instr) => DynFlags -> NCGConfig -> Module -> ModLocation@@ -391,7 +396,8 @@ map (pprNatCmmDecl ncgImpl) native -- force evaluation all this stuff to avoid space leaks- {-# SCC "seqString" #-} evaluate $ seqList (showSDoc dflags $ vcat $ map ppr imports) ()+ let platform = targetPlatform dflags+ {-# SCC "seqString" #-} evaluate $ seqList (showSDoc dflags $ vcat $ map (pdoc platform) imports) () let !labels' = if ncgDwarfEnabled config then cmmDebugLabels isMetaInstr native else []@@ -425,7 +431,7 @@ -- Dumping the output of each stage along the way. -- Global conflict graph and NGC stats cmmNativeGen- :: forall statics instr jumpDest. (Instruction instr, Outputable statics, Outputable jumpDest)+ :: forall statics instr jumpDest. (Instruction instr, OutputableP Platform statics, Outputable jumpDest) => DynFlags -> Module -> ModLocation -> NcgImpl statics instr jumpDest@@ -450,7 +456,7 @@ let weights = ncgCfgWeights config let proc_name = case cmm of- (CmmProc _ entry_label _ _) -> ppr entry_label+ (CmmProc _ entry_label _ _) -> pdoc platform entry_label _ -> text "DataChunk" -- rewrite assignments to global regs@@ -465,10 +471,10 @@ dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm" FormatCMM- (pprCmmGroup [opt_cmm])+ (pprCmmGroup platform [opt_cmm]) let cmmCfg = {-# SCC "getCFG" #-}- getCfgProc weights opt_cmm+ getCfgProc platform weights opt_cmm -- generate native code from cmm let ((native, lastMinuteImports, fileIds', nativeCfgWeights), usGen) =@@ -797,7 +803,7 @@ doPpr lbl = (lbl, renderWithContext (ncgAsmContext config)- (pprCLabel_NCG platform lbl))+ (pprCLabel platform AsmStyle lbl)) -- ----------------------------------------------------------------------------- -- Generate jump tables@@ -1143,7 +1149,7 @@ initNCGConfig :: DynFlags -> NCGConfig initNCGConfig dflags = NCGConfig { ncgPlatform = targetPlatform dflags- , ncgAsmContext = initSDocContext dflags (mkCodeStyle AsmStyle)+ , ncgAsmContext = initSDocContext dflags (PprCode AsmStyle) , ncgProcAlignment = cmmProcAlignment dflags , ncgExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags , ncgPIC = positionIndependent dflags
compiler/GHC/CmmToAsm/CFG.hs view
@@ -45,6 +45,7 @@ #include "GhclibHsVersions.h" import GHC.Prelude+import GHC.Platform import GHC.Cmm.BlockId import GHC.Cmm as Cmm@@ -583,12 +584,12 @@ -} -- | Generate weights for a Cmm proc based on some simple heuristics.-getCfgProc :: Weights -> RawCmmDecl -> CFG-getCfgProc _ (CmmData {}) = mapEmpty-getCfgProc weights (CmmProc _info _lab _live graph) = getCfg weights graph+getCfgProc :: Platform -> Weights -> RawCmmDecl -> CFG+getCfgProc _ _ (CmmData {}) = mapEmpty+getCfgProc platform weights (CmmProc _info _lab _live graph) = getCfg platform weights graph -getCfg :: Weights -> CmmGraph -> CFG-getCfg weights graph =+getCfg :: Platform -> Weights -> CmmGraph -> CFG+getCfg platform weights graph = foldl' insertEdge edgelessCfg $ concatMap getBlockEdges blocks where Weights@@ -647,7 +648,7 @@ other -> panic "Foo" $ ASSERT2(False, ppr "Unknown successor cause:" <>- (ppr branch <+> text "=>" <> ppr (G.successors other)))+ (pdoc platform branch <+> text "=>" <> pdoc platform (G.successors other))) map (\x -> ((bid,x),mkEdgeInfo 0)) $ G.successors other where bid = G.entryLabel block
compiler/GHC/CmmToAsm/Dwarf.hs view
@@ -73,7 +73,7 @@ , dwarfInfoSection platform , compileUnitHeader platform unitU , pprDwarfInfo platform haveSrc dwarfUnit- , compileUnitFooter unitU+ , compileUnitFooter platform unitU ] -- .debug_line section: Generated mainly by the assembler, but we@@ -109,9 +109,9 @@ compileUnitHeader :: Platform -> Unique -> SDoc compileUnitHeader platform unitU = let cuLabel = mkAsmTempLabel unitU -- sits right before initialLength field- length = ppr (mkAsmTempEndLabel cuLabel) <> char '-' <> ppr cuLabel+ length = pdoc platform (mkAsmTempEndLabel cuLabel) <> char '-' <> pdoc platform cuLabel <> text "-4" -- length of initialLength field- in vcat [ ppr cuLabel <> colon+ in vcat [ pdoc platform cuLabel <> colon , text "\t.long " <> length -- compilation unit size , pprHalf 3 -- DWARF version , sectionOffset platform (ptext dwarfAbbrevLabel) (ptext dwarfAbbrevLabel)@@ -120,10 +120,10 @@ ] -- | Compilation unit footer, mainly establishing size of debug sections-compileUnitFooter :: Unique -> SDoc-compileUnitFooter unitU =+compileUnitFooter :: Platform -> Unique -> SDoc+compileUnitFooter platform unitU = let cuEndLabel = mkAsmTempEndLabel $ mkAsmTempLabel unitU- in ppr cuEndLabel <> colon+ in pdoc platform cuEndLabel <> colon -- | Splits the blocks by procedures. In the result all nested blocks -- will come from the same procedure as the top-level block. See
compiler/GHC/CmmToAsm/Dwarf/Types.hs view
@@ -1,3 +1,8 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+ module GHC.CmmToAsm.Dwarf.Types ( -- * Dwarf information DwarfInfo(..)@@ -159,9 +164,8 @@ -- | Print a CLabel name in a ".stringz \"LABEL\"" pprLabelString :: Platform -> CLabel -> SDoc pprLabelString platform label =- pprString' -- we don't need to escape the string as labels don't contain exotic characters- $ withPprStyle (mkCodeStyle CStyle) -- force CStyle (foreign labels may be printed differently in AsmStyle)- $ pprCLabel_NCG platform label+ pprString' -- we don't need to escape the string as labels don't contain exotic characters+ $ pprCLabel platform CStyle label -- pretty-print as C label (foreign labels may be printed differently in Asm) -- | Prints assembler data corresponding to DWARF info records. Note -- that the binary format of this is parameterized in @abbrevDecls@ and@@ -174,19 +178,19 @@ $$ pprString producer $$ pprData4 dW_LANG_Haskell $$ pprString compDir- $$ pprWord platform (ppr lowLabel)- $$ pprWord platform (ppr highLabel)+ $$ pprWord platform (pdoc platform lowLabel)+ $$ pprWord platform (pdoc platform highLabel) $$ if haveSrc then sectionOffset platform (ptext lineLbl) (ptext dwarfLineLabel) else empty pprDwarfInfoOpen platform _ (DwarfSubprogram _ name label parent) =- ppr (mkAsmTempDieLabel label) <> colon+ pdoc platform (mkAsmTempDieLabel label) <> colon $$ pprAbbrev abbrev $$ pprString name $$ pprLabelString platform label $$ pprFlag (externallyVisibleCLabel label)- $$ pprWord platform (ppr label)- $$ pprWord platform (ppr $ mkAsmTempEndLabel label)+ $$ pprWord platform (pdoc platform label)+ $$ pprWord platform (pdoc platform $ mkAsmTempEndLabel label) $$ pprByte 1 $$ pprByte dW_OP_call_frame_cfa $$ parentValue@@ -194,17 +198,17 @@ abbrev = case parent of Nothing -> DwAbbrSubprogram Just _ -> DwAbbrSubprogramWithParent parentValue = maybe empty pprParentDie parent- pprParentDie sym = sectionOffset platform (ppr sym) (ptext dwarfInfoLabel)+ pprParentDie sym = sectionOffset platform (pdoc platform sym) (ptext dwarfInfoLabel) pprDwarfInfoOpen platform _ (DwarfBlock _ label Nothing) =- ppr (mkAsmTempDieLabel label) <> colon+ pdoc platform (mkAsmTempDieLabel label) <> colon $$ pprAbbrev DwAbbrBlockWithoutCode $$ pprLabelString platform label pprDwarfInfoOpen platform _ (DwarfBlock _ label (Just marker)) =- ppr (mkAsmTempDieLabel label) <> colon+ pdoc platform (mkAsmTempDieLabel label) <> colon $$ pprAbbrev DwAbbrBlock $$ pprLabelString platform label- $$ pprWord platform (ppr marker)- $$ pprWord platform (ppr $ mkAsmTempEndLabel marker)+ $$ pprWord platform (pdoc platform marker)+ $$ pprWord platform (pdoc platform $ mkAsmTempEndLabel marker) pprDwarfInfoOpen _ _ (DwarfSrcNote ss) = pprAbbrev DwAbbrGhcSrcNote $$ pprString' (ftext $ srcSpanFile ss)@@ -240,7 +244,7 @@ initialLength = 8 + paddingSize + (1 + length arngs) * 2 * wordSize in pprDwWord (ppr initialLength) $$ pprHalf 2- $$ sectionOffset platform (ppr $ mkAsmTempLabel $ unitU)+ $$ sectionOffset platform (pdoc platform $ mkAsmTempLabel $ unitU) (ptext dwarfInfoLabel) $$ pprByte (fromIntegral wordSize) $$ pprByte 0@@ -252,10 +256,10 @@ $$ pprWord platform (char '0') pprDwarfARange :: Platform -> DwarfARange -> SDoc-pprDwarfARange platform arng = pprWord platform (ppr $ dwArngStartLabel arng) $$ pprWord platform length+pprDwarfARange platform arng = pprWord platform (pdoc platform $ dwArngStartLabel arng) $$ pprWord platform length where- length = ppr (dwArngEndLabel arng)- <> char '-' <> ppr (dwArngStartLabel arng)+ length = pdoc platform (dwArngEndLabel arng)+ <> char '-' <> pdoc platform (dwArngStartLabel arng) -- | Information about unwind instructions for a procedure. This -- corresponds to a "Common Information Entry" (CIE) in DWARF.@@ -286,8 +290,8 @@ -- in the block } -instance Outputable DwarfFrameBlock where- ppr (DwarfFrameBlock hasInfo unwinds) = braces $ ppr hasInfo <+> ppr unwinds+instance OutputableP env CLabel => OutputableP env DwarfFrameBlock where+ pdoc env (DwarfFrameBlock hasInfo unwinds) = braces $ ppr hasInfo <+> pdoc env unwinds -- | Header for the @.debug_frame@ section. Here we emit the "Common -- Information Entry" record that establishes general call frame@@ -296,7 +300,7 @@ pprDwarfFrame platform DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCieProcs=procs} = let cieStartLabel= mkAsmTempDerivedLabel cieLabel (fsLit "_start") cieEndLabel = mkAsmTempEndLabel cieLabel- length = ppr cieEndLabel <> char '-' <> ppr cieStartLabel+ length = pdoc platform cieEndLabel <> char '-' <> pdoc platform cieStartLabel spReg = dwarfGlobalRegNo platform Sp retReg = dwarfReturnRegNo platform wordSize = platformWordSizeInBytes platform@@ -309,9 +313,9 @@ ArchX86 -> pprByte dW_CFA_same_value $$ pprLEBWord 4 ArchX86_64 -> pprByte dW_CFA_same_value $$ pprLEBWord 7 _ -> empty- in vcat [ ppr cieLabel <> colon+ in vcat [ pdoc platform cieLabel <> colon , pprData4' length -- Length of CIE- , ppr cieStartLabel <> colon+ , pdoc platform cieStartLabel <> colon , pprData4' (text "-1") -- Common Information Entry marker (-1 = 0xf..f) , pprByte 3 -- CIE version (we require DWARF 3)@@ -339,7 +343,7 @@ , pprLEBWord 0 ] $$ wordAlign platform $$- ppr cieEndLabel <> colon $$+ pdoc platform cieEndLabel <> colon $$ -- Procedure unwind tables vcat (map (pprFrameProc platform cieLabel cieInit) procs) @@ -353,18 +357,18 @@ procEnd = mkAsmTempEndLabel procLbl ifInfo str = if hasInfo then text str else empty -- see [Note: Info Offset]- in vcat [ whenPprDebug $ text "# Unwinding for" <+> ppr procLbl <> colon- , pprData4' (ppr fdeEndLabel <> char '-' <> ppr fdeLabel)- , ppr fdeLabel <> colon- , pprData4' (ppr frameLbl <> char '-' <>+ in vcat [ whenPprDebug $ text "# Unwinding for" <+> pdoc platform procLbl <> colon+ , pprData4' (pdoc platform fdeEndLabel <> char '-' <> pdoc platform fdeLabel)+ , pdoc platform fdeLabel <> colon+ , pprData4' (pdoc platform frameLbl <> char '-' <> ptext dwarfFrameLabel) -- Reference to CIE- , pprWord platform (ppr procLbl <> ifInfo "-1") -- Code pointer- , pprWord platform (ppr procEnd <> char '-' <>- ppr procLbl <> ifInfo "+1") -- Block byte length+ , pprWord platform (pdoc platform procLbl <> ifInfo "-1") -- Code pointer+ , pprWord platform (pdoc platform procEnd <> char '-' <>+ pdoc platform procLbl <> ifInfo "+1") -- Block byte length ] $$ vcat (S.evalState (mapM (pprFrameBlock platform) blocks) initUw) $$ wordAlign platform $$- ppr fdeEndLabel <> colon+ pdoc platform fdeEndLabel <> colon -- | Generates unwind information for a block. We only generate -- instructions where unwind information actually changes. This small@@ -396,7 +400,7 @@ then (empty, oldUws) else let -- see [Note: Info Offset] needsOffset = firstDecl && hasInfo- lblDoc = ppr lbl <>+ lblDoc = pdoc platform lbl <> if needsOffset then text "-1" else empty doc = pprByte dW_CFA_set_loc $$ pprWord platform lblDoc $$ vcat (map (uncurry $ pprSetUnwind platform) changed)@@ -499,7 +503,7 @@ pprE (UwReg g i) = pprByte (dW_OP_breg0+dwarfGlobalRegNo platform g) $$ pprLEBInt i pprE (UwDeref u) = pprE u $$ pprByte dW_OP_deref- pprE (UwLabel l) = pprByte dW_OP_addr $$ pprWord platform (ppr l)+ pprE (UwLabel l) = pprByte dW_OP_addr $$ pprWord platform (pdoc platform l) pprE (UwPlus u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_plus pprE (UwMinus u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_minus pprE (UwTimes u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_mul
compiler/GHC/CmmToAsm/PIC.hs view
@@ -699,7 +699,7 @@ _ -> panic "PIC.pprImportedSymbol: no match" where platform = ncgPlatform config- ppr_lbl = pprCLabel_NCG platform+ ppr_lbl = pprCLabel platform AsmStyle arch = platformArch platform os = platformOS platform pic = ncgPIC config
compiler/GHC/CmmToAsm/PPC/Ppr.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE LambdaCase #-}+ ----------------------------------------------------------------------------- -- -- Pretty-printing assembly language@@ -59,19 +61,19 @@ -- special case for code without info table: pprSectionAlign config (Section Text lbl) $$ (case platformArch platform of- ArchPPC_64 ELF_V1 -> pprFunctionDescriptor lbl- ArchPPC_64 ELF_V2 -> pprFunctionPrologue lbl+ ArchPPC_64 ELF_V1 -> pprFunctionDescriptor platform lbl+ ArchPPC_64 ELF_V2 -> pprFunctionPrologue platform lbl _ -> pprLabel platform lbl) $$ -- blocks guaranteed not null, -- so label needed vcat (map (pprBasicBlock config top_info) blocks) $$ (if ncgDwarfEnabled config- then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$+ then pdoc platform (mkAsmTempEndLabel lbl) <> char ':' else empty) $$ pprSizeDecl platform lbl Just (CmmStaticsRaw info_lbl _) -> pprSectionAlign config (Section Text info_lbl) $$ (if platformHasSubsectionsViaSymbols platform- then ppr (mkDeadStripPreventer info_lbl) <> char ':'+ then pdoc platform (mkDeadStripPreventer info_lbl) <> char ':' else empty) $$ vcat (map (pprBasicBlock config top_info) blocks) $$ -- above: Even the first block gets a label, because with branch-chain@@ -80,9 +82,9 @@ then -- See Note [Subsections Via Symbols] in X86/Ppr.hs text "\t.long "- <+> ppr info_lbl+ <+> pdoc platform info_lbl <+> char '-'- <+> ppr (mkDeadStripPreventer info_lbl)+ <+> pdoc platform (mkDeadStripPreventer info_lbl) else empty) $$ pprSizeDecl platform info_lbl @@ -93,37 +95,37 @@ then text "\t.size" <+> prettyLbl <> text ", .-" <> codeLbl else empty where- prettyLbl = ppr lbl+ prettyLbl = pdoc platform lbl codeLbl | platformArch platform == ArchPPC_64 ELF_V1 = char '.' <> prettyLbl | otherwise = prettyLbl -pprFunctionDescriptor :: CLabel -> SDoc-pprFunctionDescriptor lab = pprGloblDecl lab+pprFunctionDescriptor :: Platform -> CLabel -> SDoc+pprFunctionDescriptor platform lab = pprGloblDecl platform lab $$ text "\t.section \".opd\", \"aw\"" $$ text "\t.align 3"- $$ ppr lab <> char ':'+ $$ pdoc platform lab <> char ':' $$ text "\t.quad ."- <> ppr lab+ <> pdoc platform lab <> text ",.TOC.@tocbase,0" $$ text "\t.previous" $$ text "\t.type"- <+> ppr lab+ <+> pdoc platform lab <> text ", @function"- $$ char '.' <> ppr lab <> char ':'+ $$ char '.' <> pdoc platform lab <> char ':' -pprFunctionPrologue :: CLabel ->SDoc-pprFunctionPrologue lab = pprGloblDecl lab+pprFunctionPrologue :: Platform -> CLabel ->SDoc+pprFunctionPrologue platform lab = pprGloblDecl platform lab $$ text ".type "- <> ppr lab+ <> pdoc platform lab <> text ", @function"- $$ ppr lab <> char ':'+ $$ pdoc platform lab <> char ':' $$ text "0:\taddis\t" <> pprReg toc <> text ",12,.TOC.-0b@ha" $$ text "\taddi\t" <> pprReg toc <> char ',' <> pprReg toc <> text ",.TOC.-0b@l"- $$ text "\t.localentry\t" <> ppr lab- <> text ",.-" <> ppr lab+ $$ text "\t.localentry\t" <> pdoc platform lab+ <> text ",.-" <> pdoc platform lab pprBasicBlock :: NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc@@ -132,7 +134,7 @@ pprLabel platform asmLbl $$ vcat (map (pprInstr platform) instrs) $$ (if ncgDwarfEnabled config- then ppr (mkAsmTempEndLabel asmLbl) <> char ':'+ then pdoc platform (mkAsmTempEndLabel asmLbl) <> char ':' else empty ) where@@ -149,15 +151,15 @@ pprDatas :: Platform -> RawCmmStatics -> SDoc -- See note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".-pprDatas _platform (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])+pprDatas platform (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) | lbl == mkIndStaticInfoLabel , let labelInd (CmmLabelOff l _) = Just l labelInd (CmmLabel l) = Just l labelInd _ = Nothing , Just ind' <- labelInd ind , alias `mayRedirectTo` ind'- = pprGloblDecl alias- $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind')+ = pprGloblDecl platform alias+ $$ text ".equiv" <+> pdoc platform alias <> comma <> pdoc platform (CmmLabel ind') pprDatas platform (CmmStaticsRaw lbl dats) = vcat (pprLabel platform lbl : map (pprData platform) dats) pprData :: Platform -> CmmStatic -> SDoc@@ -167,23 +169,23 @@ CmmUninitialised bytes -> text ".space " <> int bytes CmmStaticLit lit -> pprDataItem platform lit -pprGloblDecl :: CLabel -> SDoc-pprGloblDecl lbl+pprGloblDecl :: Platform -> CLabel -> SDoc+pprGloblDecl platform lbl | not (externallyVisibleCLabel lbl) = empty- | otherwise = text ".globl " <> ppr lbl+ | otherwise = text ".globl " <> pdoc platform lbl pprTypeAndSizeDecl :: Platform -> CLabel -> SDoc pprTypeAndSizeDecl platform lbl = if platformOS platform == OSLinux && externallyVisibleCLabel lbl then text ".type " <>- ppr lbl <> text ", @object"+ pdoc platform lbl <> text ", @object" else empty pprLabel :: Platform -> CLabel -> SDoc pprLabel platform lbl =- pprGloblDecl lbl+ pprGloblDecl platform lbl $$ pprTypeAndSizeDecl platform lbl- $$ (ppr lbl <> char ':')+ $$ (pdoc platform lbl <> char ':') -- ----------------------------------------------------------------------------- -- pprInstr: print an 'Instr'@@ -230,57 +232,42 @@ GU -> sLit "gt"; LEU -> sLit "le"; }) -pprImm :: Imm -> SDoc--pprImm (ImmInt i) = int i-pprImm (ImmInteger i) = integer i-pprImm (ImmCLbl l) = ppr l-pprImm (ImmIndex l i) = ppr l <> char '+' <> int i-pprImm (ImmLit s) = s-pprImm (ImmFloat f) = float $ fromRational f-pprImm (ImmDouble d) = double $ fromRational d--pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b-pprImm (ImmConstantDiff a b) = pprImm a <> char '-'- <> lparen <> pprImm b <> rparen--pprImm (LO (ImmInt i)) = pprImm (LO (ImmInteger (toInteger i)))-pprImm (LO (ImmInteger i)) = pprImm (ImmInteger (toInteger lo16))- where- lo16 = fromInteger (i .&. 0xffff) :: Int16--pprImm (LO i)- = pprImm i <> text "@l"--pprImm (HI i)- = pprImm i <> text "@h"--pprImm (HA (ImmInt i)) = pprImm (HA (ImmInteger (toInteger i)))-pprImm (HA (ImmInteger i)) = pprImm (ImmInteger ha16)- where- ha16 = if lo16 >= 0x8000 then hi16+1 else hi16- hi16 = (i `shiftR` 16)- lo16 = i .&. 0xffff--pprImm (HA i)- = pprImm i <> text "@ha"+pprImm :: Platform -> Imm -> SDoc+pprImm platform = \case+ ImmInt i -> int i+ ImmInteger i -> integer i+ ImmCLbl l -> pdoc platform l+ ImmIndex l i -> pdoc platform l <> char '+' <> int i+ ImmLit s -> s+ ImmFloat f -> float $ fromRational f+ ImmDouble d -> double $ fromRational d+ ImmConstantSum a b -> pprImm platform a <> char '+' <> pprImm platform b+ ImmConstantDiff a b -> pprImm platform a <> char '-' <> lparen <> pprImm platform b <> rparen+ LO (ImmInt i) -> pprImm platform (LO (ImmInteger (toInteger i)))+ LO (ImmInteger i) -> pprImm platform (ImmInteger (toInteger lo16))+ where+ lo16 = fromInteger (i .&. 0xffff) :: Int16 -pprImm (HIGHERA i)- = pprImm i <> text "@highera"+ LO i -> pprImm platform i <> text "@l"+ HI i -> pprImm platform i <> text "@h"+ HA (ImmInt i) -> pprImm platform (HA (ImmInteger (toInteger i)))+ HA (ImmInteger i) -> pprImm platform (ImmInteger ha16)+ where+ ha16 = if lo16 >= 0x8000 then hi16+1 else hi16+ hi16 = (i `shiftR` 16)+ lo16 = i .&. 0xffff -pprImm (HIGHESTA i)- = pprImm i <> text "@highesta"+ HA i -> pprImm platform i <> text "@ha"+ HIGHERA i -> pprImm platform i <> text "@highera"+ HIGHESTA i -> pprImm platform i <> text "@highesta" -pprAddr :: AddrMode -> SDoc-pprAddr (AddrRegReg r1 r2)- = pprReg r1 <> char ',' <+> pprReg r2-pprAddr (AddrRegImm r1 (ImmInt i))- = hcat [ int i, char '(', pprReg r1, char ')' ]-pprAddr (AddrRegImm r1 (ImmInteger i))- = hcat [ integer i, char '(', pprReg r1, char ')' ]-pprAddr (AddrRegImm r1 imm)- = hcat [ pprImm imm, char '(', pprReg r1, char ')' ]+pprAddr :: Platform -> AddrMode -> SDoc+pprAddr platform = \case+ AddrRegReg r1 r2 -> pprReg r1 <> char ',' <+> pprReg r2+ AddrRegImm r1 (ImmInt i) -> hcat [ int i, char '(', pprReg r1, char ')' ]+ AddrRegImm r1 (ImmInteger i) -> hcat [ integer i, char '(', pprReg r1, char ')' ]+ AddrRegImm r1 imm -> hcat [ pprImm platform imm, char '(', pprReg r1, char ')' ] pprSectionAlign :: NCGConfig -> Section -> SDoc@@ -321,11 +308,11 @@ imm = litToImm lit archPPC_64 = not $ target32Bit platform - ppr_item II8 _ = [text "\t.byte\t" <> pprImm imm]- ppr_item II16 _ = [text "\t.short\t" <> pprImm imm]- ppr_item II32 _ = [text "\t.long\t" <> pprImm imm]+ ppr_item II8 _ = [text "\t.byte\t" <> pprImm platform imm]+ ppr_item II16 _ = [text "\t.short\t" <> pprImm platform imm]+ ppr_item II32 _ = [text "\t.long\t" <> pprImm platform imm] ppr_item II64 _- | archPPC_64 = [text "\t.quad\t" <> pprImm imm]+ | archPPC_64 = [text "\t.quad\t" <> pprImm platform imm] ppr_item II64 (CmmInt x _) | not archPPC_64 =@@ -336,8 +323,8 @@ <> int (fromIntegral (fromIntegral x :: Word32))] - ppr_item FF32 _ = [text "\t.float\t" <> pprImm imm]- ppr_item FF64 _ = [text "\t.double\t" <> pprImm imm]+ ppr_item FF32 _ = [text "\t.float\t" <> pprImm platform imm]+ ppr_item FF64 _ = [text "\t.double\t" <> pprImm platform imm] ppr_item _ _ = panic "PPC.Ppr.pprDataItem: no match"@@ -401,7 +388,7 @@ char '\t', pprReg reg, text ", ",- pprAddr addr+ pprAddr platform addr ] LDFAR fmt reg (AddrRegImm source off)@@ -423,7 +410,7 @@ text "arx\t", pprReg reg1, text ", ",- pprAddr addr+ pprAddr platform addr ] LA fmt reg addr@@ -443,7 +430,7 @@ char '\t', pprReg reg, text ", ",- pprAddr addr+ pprAddr platform addr ] ST fmt reg addr@@ -456,7 +443,7 @@ char '\t', pprReg reg, text ", ",- pprAddr addr+ pprAddr platform addr ] STFAR fmt reg (AddrRegImm source off)@@ -478,7 +465,7 @@ char '\t', pprReg reg, text ", ",- pprAddr addr+ pprAddr platform addr ] STC fmt reg1 addr@@ -491,7 +478,7 @@ text "cx.\t", pprReg reg1, text ", ",- pprAddr addr+ pprAddr platform addr ] LIS reg imm@@ -501,7 +488,7 @@ char '\t', pprReg reg, text ", ",- pprImm imm+ pprImm platform imm ] LI reg imm@@ -511,7 +498,7 @@ char '\t', pprReg reg, text ", ",- pprImm imm+ pprImm platform imm ] MR reg1 reg2@@ -534,7 +521,7 @@ char '\t', pprReg reg, text ", ",- pprRI ri+ pprRI platform ri ] where op = hcat [@@ -552,7 +539,7 @@ char '\t', pprReg reg, text ", ",- pprRI ri+ pprRI platform ri ] where op = hcat [@@ -570,7 +557,7 @@ pprCond cond, pprPrediction prediction, char '\t',- ppr lbl+ pdoc platform lbl ] where lbl = mkLocalBlockLabel (getUnique blockid) pprPrediction p = case p of@@ -588,7 +575,7 @@ ], hcat [ text "\tb\t",- ppr lbl+ pdoc platform lbl ] ] where lbl = mkLocalBlockLabel (getUnique blockid)@@ -605,7 +592,7 @@ char '\t', text "b", char '\t',- ppr lbl+ pdoc platform lbl ] MTCTR reg@@ -636,12 +623,12 @@ -- they'd technically be more like 'ForeignLabel's. hcat [ text "\tbl\t.",- ppr lbl+ pdoc platform lbl ] _ -> hcat [ text "\tbl\t",- ppr lbl+ pdoc platform lbl ] BCTRL _@@ -651,7 +638,7 @@ ] ADD reg1 reg2 ri- -> pprLogic (sLit "add") reg1 reg2 ri+ -> pprLogic platform (sLit "add") reg1 reg2 ri ADDIS reg1 reg2 imm -> hcat [@@ -662,26 +649,26 @@ text ", ", pprReg reg2, text ", ",- pprImm imm+ pprImm platform imm ] ADDO reg1 reg2 reg3- -> pprLogic (sLit "addo") reg1 reg2 (RIReg reg3)+ -> pprLogic platform (sLit "addo") reg1 reg2 (RIReg reg3) ADDC reg1 reg2 reg3- -> pprLogic (sLit "addc") reg1 reg2 (RIReg reg3)+ -> pprLogic platform (sLit "addc") reg1 reg2 (RIReg reg3) ADDE reg1 reg2 reg3- -> pprLogic (sLit "adde") reg1 reg2 (RIReg reg3)+ -> pprLogic platform (sLit "adde") reg1 reg2 (RIReg reg3) ADDZE reg1 reg2 -> pprUnary (sLit "addze") reg1 reg2 SUBF reg1 reg2 reg3- -> pprLogic (sLit "subf") reg1 reg2 (RIReg reg3)+ -> pprLogic platform (sLit "subf") reg1 reg2 (RIReg reg3) SUBFO reg1 reg2 reg3- -> pprLogic (sLit "subfo") reg1 reg2 (RIReg reg3)+ -> pprLogic platform (sLit "subfo") reg1 reg2 (RIReg reg3) SUBFC reg1 reg2 ri -> hcat [@@ -695,14 +682,14 @@ text ", ", pprReg reg2, text ", ",- pprRI ri+ pprRI platform ri ] SUBFE reg1 reg2 reg3- -> pprLogic (sLit "subfe") reg1 reg2 (RIReg reg3)+ -> pprLogic platform (sLit "subfe") reg1 reg2 (RIReg reg3) MULL fmt reg1 reg2 ri- -> pprMul fmt reg1 reg2 ri+ -> pprMul platform fmt reg1 reg2 ri MULLO fmt reg1 reg2 reg3 -> hcat [@@ -777,23 +764,23 @@ text ", ", pprReg reg2, text ", ",- pprImm imm+ pprImm platform imm ] AND reg1 reg2 ri- -> pprLogic (sLit "and") reg1 reg2 ri+ -> pprLogic platform (sLit "and") reg1 reg2 ri ANDC reg1 reg2 reg3- -> pprLogic (sLit "andc") reg1 reg2 (RIReg reg3)+ -> pprLogic platform (sLit "andc") reg1 reg2 (RIReg reg3) NAND reg1 reg2 reg3- -> pprLogic (sLit "nand") reg1 reg2 (RIReg reg3)+ -> pprLogic platform (sLit "nand") reg1 reg2 (RIReg reg3) OR reg1 reg2 ri- -> pprLogic (sLit "or") reg1 reg2 ri+ -> pprLogic platform (sLit "or") reg1 reg2 ri XOR reg1 reg2 ri- -> pprLogic (sLit "xor") reg1 reg2 ri+ -> pprLogic platform (sLit "xor") reg1 reg2 ri ORIS reg1 reg2 imm -> hcat [@@ -804,7 +791,7 @@ text ", ", pprReg reg2, text ", ",- pprImm imm+ pprImm platform imm ] XORIS reg1 reg2 imm@@ -816,7 +803,7 @@ text ", ", pprReg reg2, text ", ",- pprImm imm+ pprImm platform imm ] EXTS fmt reg1 reg2@@ -875,21 +862,21 @@ II32 -> "slw" II64 -> "sld" _ -> panic "PPC.Ppr.pprInstr: shift illegal size"- in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri)+ in pprLogic platform (sLit op) reg1 reg2 (limitShiftRI fmt ri) SR fmt reg1 reg2 ri -> let op = case fmt of II32 -> "srw" II64 -> "srd" _ -> panic "PPC.Ppr.pprInstr: shift illegal size"- in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri)+ in pprLogic platform (sLit op) reg1 reg2 (limitShiftRI fmt ri) SRA fmt reg1 reg2 ri -> let op = case fmt of II32 -> "sraw" II64 -> "srad" _ -> panic "PPC.Ppr.pprInstr: shift illegal size"- in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri)+ in pprLogic platform (sLit op) reg1 reg2 (limitShiftRI fmt ri) RLWINM reg1 reg2 sh mb me -> hcat [@@ -1019,8 +1006,8 @@ NOP -> text "\tnop" -pprLogic :: PtrString -> Reg -> Reg -> RI -> SDoc-pprLogic op reg1 reg2 ri = hcat [+pprLogic :: Platform -> PtrString -> Reg -> Reg -> RI -> SDoc+pprLogic platform op reg1 reg2 ri = hcat [ char '\t', ptext op, case ri of@@ -1031,12 +1018,12 @@ text ", ", pprReg reg2, text ", ",- pprRI ri+ pprRI platform ri ] -pprMul :: Format -> Reg -> Reg -> RI -> SDoc-pprMul fmt reg1 reg2 ri = hcat [+pprMul :: Platform -> Format -> Reg -> Reg -> RI -> SDoc+pprMul platform fmt reg1 reg2 ri = hcat [ char '\t', text "mull", case ri of@@ -1050,7 +1037,7 @@ text ", ", pprReg reg2, text ", ",- pprRI ri+ pprRI platform ri ] @@ -1096,9 +1083,9 @@ pprReg reg3 ] -pprRI :: RI -> SDoc-pprRI (RIReg r) = pprReg r-pprRI (RIImm r) = pprImm r+pprRI :: Platform -> RI -> SDoc+pprRI _ (RIReg r) = pprReg r+pprRI platform (RIImm r) = pprImm platform r pprFFormat :: Format -> SDoc
compiler/GHC/CmmToAsm/Ppr.hs view
@@ -196,7 +196,7 @@ platform = ncgPlatform config splitSections = ncgSplitSections config subsection- | splitSections = sep <> ppr suffix+ | splitSections = sep <> pdoc platform suffix | otherwise = empty header = case t of Text -> sLit ".text"
compiler/GHC/CmmToAsm/Reg/Graph.hs view
@@ -1,6 +1,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-} + -- | Graph coloring register allocator. module GHC.CmmToAsm.Reg.Graph ( regAlloc@@ -46,7 +50,7 @@ -- | The top level of the graph coloring register allocator. regAlloc- :: (Outputable statics, Instruction instr)+ :: (OutputableP Platform statics, Instruction instr) => NCGConfig -> UniqFM RegClass (UniqSet RealReg) -- ^ registers we can use for allocation -> UniqSet Int -- ^ set of available spill slots.@@ -91,7 +95,7 @@ regAlloc_spin :: forall instr statics. (Instruction instr,- Outputable statics)+ OutputableP Platform statics) => NCGConfig -> Int -- ^ Number of solver iterations we've already performed. -> Color.Triv VirtualReg RegClass RealReg@@ -388,7 +392,7 @@ -- | Patch registers in code using the reg -> reg mapping in this graph. patchRegsFromGraph- :: (Outputable statics, Instruction instr)+ :: (OutputableP Platform statics, Instruction instr) => Platform -> Color.Graph VirtualReg RegClass RealReg -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr
compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs view
@@ -1,5 +1,9 @@ {-# LANGUAGE BangPatterns, CPP, DeriveFunctor #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-} + {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- | Carries interesting info for debugging / profiling of the@@ -113,13 +117,13 @@ deriving (Functor) -instance (Outputable statics, Outputable instr)+instance (OutputableP Platform statics, OutputableP Platform instr) => Outputable (RegAllocStats statics instr) where ppr (s@RegAllocStatsStart{}) = text "# Start" $$ text "# Native code with liveness information."- $$ ppr (raLiveCmm s)+ $$ pdoc (raPlatform s) (raLiveCmm s) $$ text "" $$ text "# Initial register conflict graph." $$ Color.dotGraph@@ -134,7 +138,7 @@ text "# Spill" $$ text "# Code with liveness information."- $$ ppr (raCode s)+ $$ pdoc (raPlatform s) (raCode s) $$ text "" $$ (if (not $ isNullUFM $ raCoalesced s)@@ -148,14 +152,14 @@ $$ text "" $$ text "# Code with spills inserted."- $$ ppr (raSpilled s)+ $$ pdoc (raPlatform s) (raSpilled s) ppr (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) }) = text "# Colored" $$ text "# Code with liveness information."- $$ ppr (raCode s)+ $$ pdoc (raPlatform s) (raCode s) $$ text "" $$ text "# Register conflict graph (colored)."@@ -174,19 +178,19 @@ else empty) $$ text "# Native code after coalescings applied."- $$ ppr (raCodeCoalesced s)+ $$ pdoc (raPlatform s) (raCodeCoalesced s) $$ text "" $$ text "# Native code after register allocation."- $$ ppr (raPatched s)+ $$ pdoc (raPlatform s) (raPatched s) $$ text "" $$ text "# Clean out unneeded spill/reloads."- $$ ppr (raSpillClean s)+ $$ pdoc (raPlatform s) (raSpillClean s) $$ text "" $$ text "# Final code, after rewriting spill/rewrite pseudo instrs."- $$ ppr (raFinal s)+ $$ pdoc (raPlatform s) (raFinal s) $$ text "" $$ text "# Score:" $$ (text "# spills inserted: " <> int spills)
compiler/GHC/CmmToAsm/Reg/Linear.hs view
@@ -205,7 +205,7 @@ -- an entry in the block map or it is the first block. -- linearRegAlloc- :: Instruction instr+ :: forall instr. Instruction instr => NCGConfig -> [BlockId] -- ^ entry points -> BlockMap RegSet@@ -231,6 +231,8 @@ ArchJavaScript -> panic "linearRegAlloc ArchJavaScript" ArchUnknown -> panic "linearRegAlloc ArchUnknown" where+ go :: (FR regs, Outputable regs)+ => regs -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int) go f = linearRegAlloc' config f entry_ids block_live sccs platform = ncgPlatform config @@ -973,4 +975,3 @@ loadTemp _ _ _ spills = return spills-
compiler/GHC/CmmToAsm/Reg/Liveness.hs view
@@ -3,7 +3,10 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-} + {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -----------------------------------------------------------------------------@@ -249,15 +252,19 @@ | otherwise = name <> (pprUFM (getUniqSet regs) (hcat . punctuate space . map ppr)) -instance Outputable LiveInfo where- ppr (LiveInfo mb_static entryIds liveVRegsOnEntry liveSlotsOnEntry)- = (ppr mb_static)+instance OutputableP env instr => OutputableP env (LiveInstr instr) where+ pdoc env i = ppr (fmap (pdoc env) i)++instance OutputableP Platform LiveInfo where+ pdoc env (LiveInfo mb_static entryIds liveVRegsOnEntry liveSlotsOnEntry)+ = (pdoc env mb_static) $$ text "# entryIds = " <> ppr entryIds $$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry $$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry) + -- | map a function across all the basic blocks in this code -- mapBlockTop@@ -503,7 +510,7 @@ -- | Strip away liveness information, yielding NatCmmDecl stripLive- :: (Outputable statics, Instruction instr)+ :: (OutputableP Platform statics, Instruction instr) => NCGConfig -> LiveCmmDecl statics instr -> NatCmmDecl statics instr@@ -511,7 +518,7 @@ stripLive config live = stripCmm live - where stripCmm :: (Outputable statics, Instruction instr)+ where stripCmm :: (OutputableP Platform statics, Instruction instr) => LiveCmmDecl statics instr -> NatCmmDecl statics instr stripCmm (CmmData sec ds) = CmmData sec ds stripCmm (CmmProc (LiveInfo info (first_id:_) _ _) label live sccs)@@ -532,14 +539,13 @@ -- | Pretty-print a `LiveCmmDecl`-pprLiveCmmDecl :: (Outputable statics, Instruction instr) => Platform -> LiveCmmDecl statics instr -> SDoc-pprLiveCmmDecl platform d = ppr (mapLiveCmmDecl (pprInstr platform) d)+pprLiveCmmDecl :: (OutputableP Platform statics, Instruction instr) => Platform -> LiveCmmDecl statics instr -> SDoc+pprLiveCmmDecl platform d = pdoc platform (mapLiveCmmDecl (pprInstr platform) d) -- | Map over instruction type in `LiveCmmDecl` mapLiveCmmDecl- :: Outputable statics- => (instr -> b)+ :: (instr -> b) -> LiveCmmDecl statics instr -> LiveCmmDecl statics b mapLiveCmmDecl f proc = fmap (fmap (fmap (fmap (fmap f)))) proc
compiler/GHC/CmmToAsm/SPARC.hs view
@@ -68,7 +68,7 @@ mkRegRegMoveInstr = SPARC.mkRegRegMoveInstr takeRegRegMoveInstr = SPARC.takeRegRegMoveInstr mkJumpInstr = SPARC.mkJumpInstr- pprInstr = const SPARC.pprInstr+ pprInstr = SPARC.pprInstr mkStackAllocInstr = panic "no sparc_mkStackAllocInstr" mkStackDeallocInstr = panic "no sparc_mkStackDeallocInstr"
compiler/GHC/CmmToAsm/SPARC/CodeGen.hs view
@@ -90,6 +90,7 @@ let (_, nodes, tail) = blockSplit block id = entryLabel block stmts = blockToList nodes+ platform <- getPlatform mid_instrs <- stmtsToInstrs stmts tail_instrs <- stmtToInstrs tail let instrs = mid_instrs `appOL` tail_instrs@@ -108,7 +109,7 @@ -- do intra-block sanity checking blocksChecked- = map (checkBlock block)+ = map (checkBlock platform block) $ BasicBlock id top : other_blocks return (blocksChecked, statics)
compiler/GHC/CmmToAsm/SPARC/CodeGen/CondCode.hs view
@@ -56,9 +56,13 @@ MO_U_Lt _ -> condIntCode LU x y MO_U_Le _ -> condIntCode LEU x y - _ -> pprPanic "SPARC.CodeGen.CondCode.getCondCode" (ppr (CmmMachOp mop [x,y]))+ _ -> do+ platform <- getPlatform+ pprPanic "SPARC.CodeGen.CondCode.getCondCode" (pdoc platform (CmmMachOp mop [x,y])) -getCondCode other = pprPanic "SPARC.CodeGen.CondCode.getCondCode" (ppr other)+getCondCode other = do+ platform <- getPlatform+ pprPanic "SPARC.CodeGen.CondCode.getCondCode" (pdoc platform other)
compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs view
@@ -209,4 +209,6 @@ iselExpr64 expr- = pprPanic "iselExpr64(sparc)" (ppr expr)+ = do+ platform <- getPlatform+ pprPanic "iselExpr64(sparc)" (pdoc platform expr)
compiler/GHC/CmmToAsm/SPARC/CodeGen/Sanity.hs view
@@ -7,6 +7,7 @@ where import GHC.Prelude+import GHC.Platform import GHC.CmmToAsm.SPARC.Instr import GHC.CmmToAsm.SPARC.Ppr () -- For Outputable instances@@ -20,11 +21,12 @@ -- | Enforce intra-block invariants. ---checkBlock :: CmmBlock+checkBlock :: Platform+ -> CmmBlock -> NatBasicBlock Instr -> NatBasicBlock Instr -checkBlock cmm block@(BasicBlock _ instrs)+checkBlock platform cmm block@(BasicBlock _ instrs) | checkBlockInstrs instrs = block @@ -32,9 +34,9 @@ = pprPanic ("SPARC.CodeGen: bad block\n") ( vcat [ text " -- cmm -----------------\n"- , ppr cmm+ , pdoc platform cmm , text " -- native code ---------\n"- , ppr block ])+ , pdoc platform block ]) checkBlockInstrs :: [Instr] -> Bool
compiler/GHC/CmmToAsm/SPARC/Ppr.hs view
@@ -1,5 +1,9 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-} + ----------------------------------------------------------------------------- -- -- Pretty-printing assembly language@@ -77,7 +81,7 @@ Just (CmmStaticsRaw info_lbl _) -> (if platformHasSubsectionsViaSymbols platform then pprSectionAlign config dspSection $$- ppr (mkDeadStripPreventer info_lbl) <> char ':'+ pdoc platform (mkDeadStripPreventer info_lbl) <> char ':' else empty) $$ vcat (map (pprBasicBlock platform top_info) blocks) $$ -- above: Even the first block gets a label, because with branch-chain@@ -86,9 +90,9 @@ then -- See Note [Subsections Via Symbols] in X86/Ppr.hs text "\t.long "- <+> ppr info_lbl+ <+> pdoc platform info_lbl <+> char '-'- <+> ppr (mkDeadStripPreventer info_lbl)+ <+> pdoc platform (mkDeadStripPreventer info_lbl) else empty) dspSection :: Section@@ -99,7 +103,7 @@ pprBasicBlock platform info_env (BasicBlock blockid instrs) = maybe_infotable $$ pprLabel platform (blockLbl blockid) $$- vcat (map pprInstr instrs)+ vcat (map (pprInstr platform) instrs) where maybe_infotable = case mapLookup blockid info_env of Nothing -> empty@@ -111,15 +115,15 @@ pprDatas :: Platform -> RawCmmStatics -> SDoc -- See note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".-pprDatas _platform (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])+pprDatas platform (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) | lbl == mkIndStaticInfoLabel , let labelInd (CmmLabelOff l _) = Just l labelInd (CmmLabel l) = Just l labelInd _ = Nothing , Just ind' <- labelInd ind , alias `mayRedirectTo` ind'- = pprGloblDecl alias- $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind')+ = pprGloblDecl platform alias+ $$ text ".equiv" <+> pdoc platform alias <> comma <> pdoc platform (CmmLabel ind') pprDatas platform (CmmStaticsRaw lbl dats) = vcat (pprLabel platform lbl : map (pprData platform) dats) pprData :: Platform -> CmmStatic -> SDoc@@ -129,28 +133,28 @@ CmmUninitialised bytes -> text ".skip " <> int bytes CmmStaticLit lit -> pprDataItem platform lit -pprGloblDecl :: CLabel -> SDoc-pprGloblDecl lbl+pprGloblDecl :: Platform -> CLabel -> SDoc+pprGloblDecl platform lbl | not (externallyVisibleCLabel lbl) = empty- | otherwise = text ".global " <> ppr lbl+ | otherwise = text ".global " <> pdoc platform lbl pprTypeAndSizeDecl :: Platform -> CLabel -> SDoc pprTypeAndSizeDecl platform lbl = if platformOS platform == OSLinux && externallyVisibleCLabel lbl- then text ".type " <> ppr lbl <> ptext (sLit ", @object")+ then text ".type " <> pdoc platform lbl <> ptext (sLit ", @object") else empty pprLabel :: Platform -> CLabel -> SDoc pprLabel platform lbl =- pprGloblDecl lbl+ pprGloblDecl platform lbl $$ pprTypeAndSizeDecl platform lbl- $$ (ppr lbl <> char ':')+ $$ (pdoc platform lbl <> char ':') -- ----------------------------------------------------------------------------- -- pprInstr: print an 'Instr' -instance Outputable Instr where- ppr instr = pprInstr instr+instance OutputableP Platform Instr where+ pdoc = pprInstr -- | Pretty print a register.@@ -273,8 +277,8 @@ -- | Pretty print an address mode.-pprAddr :: AddrMode -> SDoc-pprAddr am+pprAddr :: Platform -> AddrMode -> SDoc+pprAddr platform am = case am of AddrRegReg r1 (RegReal (RealRegSingle 0)) -> pprReg r1@@ -297,30 +301,30 @@ pp_sign = if i > 0 then char '+' else empty AddrRegImm r1 imm- -> hcat [ pprReg r1, char '+', pprImm imm ]+ -> hcat [ pprReg r1, char '+', pprImm platform imm ] -- | Pretty print an immediate value.-pprImm :: Imm -> SDoc-pprImm imm+pprImm :: Platform -> Imm -> SDoc+pprImm platform imm = case imm of ImmInt i -> int i ImmInteger i -> integer i- ImmCLbl l -> ppr l- ImmIndex l i -> ppr l <> char '+' <> int i+ ImmCLbl l -> pdoc platform l+ ImmIndex l i -> pdoc platform l <> char '+' <> int i ImmLit s -> s ImmConstantSum a b- -> pprImm a <> char '+' <> pprImm b+ -> pprImm platform a <> char '+' <> pprImm platform b ImmConstantDiff a b- -> pprImm a <> char '-' <> lparen <> pprImm b <> rparen+ -> pprImm platform a <> char '-' <> lparen <> pprImm platform b <> rparen LO i- -> hcat [ text "%lo(", pprImm i, rparen ]+ -> hcat [ text "%lo(", pprImm platform i, rparen ] HI i- -> hcat [ text "%hi(", pprImm i, rparen ]+ -> hcat [ text "%hi(", pprImm platform i, rparen ] -- these should have been converted to bytes and placed -- in the data section.@@ -360,19 +364,19 @@ where imm = litToImm lit - ppr_item II8 _ = [text "\t.byte\t" <> pprImm imm]- ppr_item II32 _ = [text "\t.long\t" <> pprImm imm]+ ppr_item II8 _ = [text "\t.byte\t" <> pprImm platform imm]+ ppr_item II32 _ = [text "\t.long\t" <> pprImm platform imm] ppr_item FF32 (CmmFloat r _) = let bs = floatToBytes (fromRational r)- in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs+ in map (\b -> text "\t.byte\t" <> pprImm platform (ImmInt b)) bs ppr_item FF64 (CmmFloat r _) = let bs = doubleToBytes (fromRational r)- in map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs+ in map (\b -> text "\t.byte\t" <> pprImm platform (ImmInt b)) bs - ppr_item II16 _ = [text "\t.short\t" <> pprImm imm]- ppr_item II64 _ = [text "\t.quad\t" <> pprImm imm]+ ppr_item II16 _ = [text "\t.short\t" <> pprImm platform imm]+ ppr_item II64 _ = [text "\t.quad\t" <> pprImm platform imm] ppr_item _ _ = panic "SPARC.Ppr.pprDataItem: no match" floatToBytes :: Float -> [Int]@@ -393,202 +397,195 @@ -- | Pretty print an instruction.-pprInstr :: Instr -> SDoc---- nuke comments.-pprInstr (COMMENT _)- = empty--pprInstr (DELTA d)- = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))---- Newblocks and LData should have been slurped out before producing the .s file.-pprInstr (NEWBLOCK _)- = panic "X86.Ppr.pprInstr: NEWBLOCK"+pprInstr :: Platform -> Instr -> SDoc+pprInstr platform = \case+ COMMENT _ -> empty -- nuke comments.+ DELTA d -> pprInstr platform (COMMENT (mkFastString ("\tdelta = " ++ show d))) -pprInstr (LDATA _ _)- = panic "PprMach.pprInstr: LDATA"+ -- Newblocks and LData should have been slurped out before producing the .s file.+ NEWBLOCK _ -> panic "X86.Ppr.pprInstr: NEWBLOCK"+ LDATA _ _ -> panic "PprMach.pprInstr: LDATA" --- 64 bit FP loads are expanded into individual instructions in CodeGen.Expand-pprInstr (LD FF64 _ reg)+ -- 64 bit FP loads are expanded into individual instructions in CodeGen.Expand+ LD FF64 _ reg | RegReal (RealRegSingle{}) <- reg- = panic "SPARC.Ppr: not emitting potentially misaligned LD FF64 instr"+ -> panic "SPARC.Ppr: not emitting potentially misaligned LD FF64 instr" -pprInstr (LD format addr reg)- = hcat [+ LD format addr reg+ -> hcat [ text "\tld", pprFormat format, char '\t', lbrack,- pprAddr addr,+ pprAddr platform addr, pp_rbracket_comma, pprReg reg ] --- 64 bit FP stores are expanded into individual instructions in CodeGen.Expand-pprInstr (ST FF64 reg _)+ -- 64 bit FP stores are expanded into individual instructions in CodeGen.Expand+ ST FF64 reg _ | RegReal (RealRegSingle{}) <- reg- = panic "SPARC.Ppr: not emitting potentially misaligned ST FF64 instr"+ -> panic "SPARC.Ppr: not emitting potentially misaligned ST FF64 instr" --- no distinction is made between signed and unsigned bytes on stores for the--- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF),--- so we call a special-purpose pprFormat for ST..-pprInstr (ST format reg addr)- = hcat [+ -- no distinction is made between signed and unsigned bytes on stores for the+ -- Sparc opcodes (at least I cannot see any, and gas is nagging me --SOF),+ -- so we call a special-purpose pprFormat for ST..+ ST format reg addr+ -> hcat [ text "\tst", pprStFormat format, char '\t', pprReg reg, pp_comma_lbracket,- pprAddr addr,+ pprAddr platform addr, rbrack ] -pprInstr (ADD x cc reg1 ri reg2)+ ADD x cc reg1 ri reg2 | not x && not cc && riZero ri- = hcat [ text "\tmov\t", pprReg reg1, comma, pprReg reg2 ]+ -> hcat [ text "\tmov\t", pprReg reg1, comma, pprReg reg2 ] | otherwise- = pprRegRIReg (if x then sLit "addx" else sLit "add") cc reg1 ri reg2+ -> pprRegRIReg platform (if x then sLit "addx" else sLit "add") cc reg1 ri reg2 -pprInstr (SUB x cc reg1 ri reg2)+ SUB x cc reg1 ri reg2 | not x && cc && reg2 == g0- = hcat [ text "\tcmp\t", pprReg reg1, comma, pprRI ri ]+ -> hcat [ text "\tcmp\t", pprReg reg1, comma, pprRI platform ri ] | not x && not cc && riZero ri- = hcat [ text "\tmov\t", pprReg reg1, comma, pprReg reg2 ]+ -> hcat [ text "\tmov\t", pprReg reg1, comma, pprReg reg2 ] | otherwise- = pprRegRIReg (if x then sLit "subx" else sLit "sub") cc reg1 ri reg2+ -> pprRegRIReg platform (if x then sLit "subx" else sLit "sub") cc reg1 ri reg2 -pprInstr (AND b reg1 ri reg2) = pprRegRIReg (sLit "and") b reg1 ri reg2+ AND b reg1 ri reg2 -> pprRegRIReg platform (sLit "and") b reg1 ri reg2 -pprInstr (ANDN b reg1 ri reg2) = pprRegRIReg (sLit "andn") b reg1 ri reg2+ ANDN b reg1 ri reg2 -> pprRegRIReg platform (sLit "andn") b reg1 ri reg2 -pprInstr (OR b reg1 ri reg2)+ OR b reg1 ri reg2 | not b && reg1 == g0- = let doit = hcat [ text "\tmov\t", pprRI ri, comma, pprReg reg2 ]- in case ri of+ -> let doit = hcat [ text "\tmov\t", pprRI platform ri, comma, pprReg reg2 ]+ in case ri of RIReg rrr | rrr == reg2 -> empty _ -> doit | otherwise- = pprRegRIReg (sLit "or") b reg1 ri reg2+ -> pprRegRIReg platform (sLit "or") b reg1 ri reg2 -pprInstr (ORN b reg1 ri reg2) = pprRegRIReg (sLit "orn") b reg1 ri reg2+ ORN b reg1 ri reg2 -> pprRegRIReg platform (sLit "orn") b reg1 ri reg2 -pprInstr (XOR b reg1 ri reg2) = pprRegRIReg (sLit "xor") b reg1 ri reg2-pprInstr (XNOR b reg1 ri reg2) = pprRegRIReg (sLit "xnor") b reg1 ri reg2+ XOR b reg1 ri reg2 -> pprRegRIReg platform (sLit "xor") b reg1 ri reg2+ XNOR b reg1 ri reg2 -> pprRegRIReg platform (sLit "xnor") b reg1 ri reg2 -pprInstr (SLL reg1 ri reg2) = pprRegRIReg (sLit "sll") False reg1 ri reg2-pprInstr (SRL reg1 ri reg2) = pprRegRIReg (sLit "srl") False reg1 ri reg2-pprInstr (SRA reg1 ri reg2) = pprRegRIReg (sLit "sra") False reg1 ri reg2+ SLL reg1 ri reg2 -> pprRegRIReg platform (sLit "sll") False reg1 ri reg2+ SRL reg1 ri reg2 -> pprRegRIReg platform (sLit "srl") False reg1 ri reg2+ SRA reg1 ri reg2 -> pprRegRIReg platform (sLit "sra") False reg1 ri reg2 -pprInstr (RDY rd) = text "\trd\t%y," <> pprReg rd-pprInstr (WRY reg1 reg2)- = text "\twr\t"+ RDY rd -> text "\trd\t%y," <> pprReg rd+ WRY reg1 reg2+ -> text "\twr\t" <> pprReg reg1 <> char ',' <> pprReg reg2 <> char ',' <> text "%y" -pprInstr (SMUL b reg1 ri reg2) = pprRegRIReg (sLit "smul") b reg1 ri reg2-pprInstr (UMUL b reg1 ri reg2) = pprRegRIReg (sLit "umul") b reg1 ri reg2-pprInstr (SDIV b reg1 ri reg2) = pprRegRIReg (sLit "sdiv") b reg1 ri reg2-pprInstr (UDIV b reg1 ri reg2) = pprRegRIReg (sLit "udiv") b reg1 ri reg2+ SMUL b reg1 ri reg2 -> pprRegRIReg platform (sLit "smul") b reg1 ri reg2+ UMUL b reg1 ri reg2 -> pprRegRIReg platform (sLit "umul") b reg1 ri reg2+ SDIV b reg1 ri reg2 -> pprRegRIReg platform (sLit "sdiv") b reg1 ri reg2+ UDIV b reg1 ri reg2 -> pprRegRIReg platform (sLit "udiv") b reg1 ri reg2 -pprInstr (SETHI imm reg)- = hcat [- text "\tsethi\t",- pprImm imm,- comma,- pprReg reg- ]+ SETHI imm reg+ -> hcat [+ text "\tsethi\t",+ pprImm platform imm,+ comma,+ pprReg reg+ ] -pprInstr NOP- = text "\tnop"+ NOP -> text "\tnop" -pprInstr (FABS format reg1 reg2)- = pprFormatRegReg (sLit "fabs") format reg1 reg2+ FABS format reg1 reg2+ -> pprFormatRegReg (sLit "fabs") format reg1 reg2 -pprInstr (FADD format reg1 reg2 reg3)- = pprFormatRegRegReg (sLit "fadd") format reg1 reg2 reg3+ FADD format reg1 reg2 reg3+ -> pprFormatRegRegReg (sLit "fadd") format reg1 reg2 reg3 -pprInstr (FCMP e format reg1 reg2)- = pprFormatRegReg (if e then sLit "fcmpe" else sLit "fcmp")- format reg1 reg2+ FCMP e format reg1 reg2+ -> pprFormatRegReg (if e then sLit "fcmpe" else sLit "fcmp")+ format reg1 reg2 -pprInstr (FDIV format reg1 reg2 reg3)- = pprFormatRegRegReg (sLit "fdiv") format reg1 reg2 reg3+ FDIV format reg1 reg2 reg3+ -> pprFormatRegRegReg (sLit "fdiv") format reg1 reg2 reg3 -pprInstr (FMOV format reg1 reg2)- = pprFormatRegReg (sLit "fmov") format reg1 reg2+ FMOV format reg1 reg2+ -> pprFormatRegReg (sLit "fmov") format reg1 reg2 -pprInstr (FMUL format reg1 reg2 reg3)- = pprFormatRegRegReg (sLit "fmul") format reg1 reg2 reg3+ FMUL format reg1 reg2 reg3+ -> pprFormatRegRegReg (sLit "fmul") format reg1 reg2 reg3 -pprInstr (FNEG format reg1 reg2)- = pprFormatRegReg (sLit "fneg") format reg1 reg2+ FNEG format reg1 reg2+ -> pprFormatRegReg (sLit "fneg") format reg1 reg2 -pprInstr (FSQRT format reg1 reg2)- = pprFormatRegReg (sLit "fsqrt") format reg1 reg2+ FSQRT format reg1 reg2+ -> pprFormatRegReg (sLit "fsqrt") format reg1 reg2 -pprInstr (FSUB format reg1 reg2 reg3)- = pprFormatRegRegReg (sLit "fsub") format reg1 reg2 reg3+ FSUB format reg1 reg2 reg3+ -> pprFormatRegRegReg (sLit "fsub") format reg1 reg2 reg3 -pprInstr (FxTOy format1 format2 reg1 reg2)- = hcat [- text "\tf",- ptext- (case format1 of- II32 -> sLit "ito"- FF32 -> sLit "sto"- FF64 -> sLit "dto"- _ -> panic "SPARC.Ppr.pprInstr.FxToY: no match"),- ptext- (case format2 of- II32 -> sLit "i\t"- II64 -> sLit "x\t"- FF32 -> sLit "s\t"- FF64 -> sLit "d\t"- _ -> panic "SPARC.Ppr.pprInstr.FxToY: no match"),- pprReg reg1, comma, pprReg reg2- ]+ FxTOy format1 format2 reg1 reg2+ -> hcat [+ text "\tf",+ ptext+ (case format1 of+ II32 -> sLit "ito"+ FF32 -> sLit "sto"+ FF64 -> sLit "dto"+ _ -> panic "SPARC.Ppr.pprInstr.FxToY: no match"),+ ptext+ (case format2 of+ II32 -> sLit "i\t"+ II64 -> sLit "x\t"+ FF32 -> sLit "s\t"+ FF64 -> sLit "d\t"+ _ -> panic "SPARC.Ppr.pprInstr.FxToY: no match"),+ pprReg reg1, comma, pprReg reg2+ ] -pprInstr (BI cond b blockid)- = hcat [- text "\tb", pprCond cond,- if b then pp_comma_a else empty,- char '\t',- ppr (blockLbl blockid)- ]+ BI cond b blockid+ -> hcat [+ text "\tb", pprCond cond,+ if b then pp_comma_a else empty,+ char '\t',+ pdoc platform (blockLbl blockid)+ ] -pprInstr (BF cond b blockid)- = hcat [- text "\tfb", pprCond cond,- if b then pp_comma_a else empty,- char '\t',- ppr (blockLbl blockid)- ]+ BF cond b blockid+ -> hcat [+ text "\tfb", pprCond cond,+ if b then pp_comma_a else empty,+ char '\t',+ pdoc platform (blockLbl blockid)+ ] -pprInstr (JMP addr) = text "\tjmp\t" <> pprAddr addr-pprInstr (JMP_TBL op _ _) = pprInstr (JMP op)+ JMP addr -> text "\tjmp\t" <> pprAddr platform addr+ JMP_TBL op _ _ -> pprInstr platform (JMP op) -pprInstr (CALL (Left imm) n _)- = hcat [ text "\tcall\t", pprImm imm, comma, int n ]+ CALL (Left imm) n _+ -> hcat [ text "\tcall\t", pprImm platform imm, comma, int n ] -pprInstr (CALL (Right reg) n _)- = hcat [ text "\tcall\t", pprReg reg, comma, int n ]+ CALL (Right reg) n _+ -> hcat [ text "\tcall\t", pprReg reg, comma, int n ] -- | Pretty print a RI-pprRI :: RI -> SDoc-pprRI (RIReg r) = pprReg r-pprRI (RIImm r) = pprImm r+pprRI :: Platform -> RI -> SDoc+pprRI platform = \case+ RIReg r -> pprReg r+ RIImm r -> pprImm platform r -- | Pretty print a two reg instruction.@@ -627,15 +624,15 @@ -- | Pretty print an instruction of two regs and a ri.-pprRegRIReg :: PtrString -> Bool -> Reg -> RI -> Reg -> SDoc-pprRegRIReg name b reg1 ri reg2+pprRegRIReg :: Platform -> PtrString -> Bool -> Reg -> RI -> Reg -> SDoc+pprRegRIReg platform name b reg1 ri reg2 = hcat [ char '\t', ptext name, if b then text "cc\t" else char '\t', pprReg reg1, comma,- pprRI ri,+ pprRI platform ri, comma, pprReg reg2 ]
compiler/GHC/CmmToAsm/X86/CodeGen.hs view
@@ -620,7 +620,9 @@ ) iselExpr64 expr- = pprPanic "iselExpr64(i386)" (ppr expr)+ = do+ platform <- getPlatform+ pprPanic "iselExpr64(i386)" (pdoc platform expr) --------------------------------------------------------------------------------@@ -1178,9 +1180,9 @@ code dst = unitOL (MOV format (OpImm imm) (OpReg dst)) return (Any format code) -getRegister' _ _ other+getRegister' platform _ other | isVecExpr other = needLlvm- | otherwise = pprPanic "getRegister(x86)" (ppr other)+ | otherwise = pprPanic "getRegister(x86)" (pdoc platform other) intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr@@ -1576,7 +1578,9 @@ _ -> condIntCode (machOpToCond mop) x y -getCondCode other = pprPanic "getCondCode(2)(x86,x86_64)" (ppr other)+getCondCode other = do+ platform <- getPlatform+ pprPanic "getCondCode(2)(x86,x86_64)" (pdoc platform other) machOpToCond :: MachOp -> Cond machOpToCond mo = case mo of
compiler/GHC/CmmToAsm/X86/Ppr.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- --@@ -92,14 +93,14 @@ pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed vcat (map (pprBasicBlock config top_info) blocks) $$ (if ncgDwarfEnabled config- then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$+ then pdoc platform (mkAsmTempEndLabel lbl) <> char ':' else empty) $$ pprSizeDecl platform lbl Just (CmmStaticsRaw info_lbl _) -> pprSectionAlign config (Section Text info_lbl) $$ pprProcAlignment config $$ (if platformHasSubsectionsViaSymbols platform- then ppr (mkDeadStripPreventer info_lbl) <> char ':'+ then pdoc platform (mkDeadStripPreventer info_lbl) <> char ':' else empty) $$ vcat (map (pprBasicBlock config top_info) blocks) $$ -- above: Even the first block gets a label, because with branch-chain@@ -107,9 +108,9 @@ (if platformHasSubsectionsViaSymbols platform then -- See Note [Subsections Via Symbols] text "\t.long "- <+> ppr info_lbl+ <+> pdoc platform info_lbl <+> char '-'- <+> ppr (mkDeadStripPreventer info_lbl)+ <+> pdoc platform (mkDeadStripPreventer info_lbl) else empty) $$ pprSizeDecl platform info_lbl @@ -117,7 +118,7 @@ pprSizeDecl :: Platform -> CLabel -> SDoc pprSizeDecl platform lbl = if osElfTarget (platformOS platform)- then text "\t.size" <+> ppr lbl <> ptext (sLit ", .-") <> ppr lbl+ then text "\t.size" <+> pdoc platform lbl <> ptext (sLit ", .-") <> pdoc platform lbl else empty pprBasicBlock :: NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc@@ -126,7 +127,7 @@ pprLabel platform asmLbl $$ vcat (map (pprInstr platform) instrs) $$ (if ncgDwarfEnabled config- then ppr (mkAsmTempEndLabel asmLbl) <> char ':'+ then pdoc (ncgPlatform config) (mkAsmTempEndLabel asmLbl) <> char ':' else empty ) where@@ -141,7 +142,7 @@ pprLabel platform infoLbl $$ c $$ (if ncgDwarfEnabled config- then ppr (mkAsmTempEndLabel infoLbl) <> char ':'+ then pdoc platform (mkAsmTempEndLabel infoLbl) <> char ':' else empty ) -- Make sure the info table has the right .loc for the block@@ -153,15 +154,15 @@ pprDatas :: NCGConfig -> (Alignment, RawCmmStatics) -> SDoc -- See note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".-pprDatas _config (_, CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])+pprDatas config (_, CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) | lbl == mkIndStaticInfoLabel , let labelInd (CmmLabelOff l _) = Just l labelInd (CmmLabel l) = Just l labelInd _ = Nothing , Just ind' <- labelInd ind , alias `mayRedirectTo` ind'- = pprGloblDecl alias- $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind')+ = pprGloblDecl (ncgPlatform config) alias+ $$ text ".equiv" <+> pdoc (ncgPlatform config) alias <> comma <> pdoc (ncgPlatform config) (CmmLabel ind') pprDatas config (align, (CmmStaticsRaw lbl dats)) = vcat (pprAlign platform align : pprLabel platform lbl : map (pprData config) dats)@@ -180,10 +181,10 @@ pprData config (CmmStaticLit lit) = pprDataItem config lit -pprGloblDecl :: CLabel -> SDoc-pprGloblDecl lbl+pprGloblDecl :: Platform -> CLabel -> SDoc+pprGloblDecl platform lbl | not (externallyVisibleCLabel lbl) = empty- | otherwise = text ".globl " <> ppr lbl+ | otherwise = text ".globl " <> pdoc platform lbl pprLabelType' :: Platform -> CLabel -> SDoc pprLabelType' platform lbl =@@ -246,14 +247,14 @@ pprTypeDecl :: Platform -> CLabel -> SDoc pprTypeDecl platform lbl = if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl- then text ".type " <> ppr lbl <> ptext (sLit ", ") <> pprLabelType' platform lbl+ then text ".type " <> pdoc platform lbl <> ptext (sLit ", ") <> pprLabelType' platform lbl else empty pprLabel :: Platform -> CLabel -> SDoc pprLabel platform lbl =- pprGloblDecl lbl+ pprGloblDecl platform lbl $$ pprTypeDecl platform lbl- $$ (ppr lbl <> char ':')+ $$ (pdoc platform lbl <> char ':') pprAlign :: Platform -> Alignment -> SDoc pprAlign platform alignment@@ -417,24 +418,23 @@ ALWAYS -> sLit "mp"}) -pprImm :: Imm -> SDoc-pprImm (ImmInt i) = int i-pprImm (ImmInteger i) = integer i-pprImm (ImmCLbl l) = ppr l-pprImm (ImmIndex l i) = ppr l <> char '+' <> int i-pprImm (ImmLit s) = s-pprImm (ImmFloat f) = float $ fromRational f-pprImm (ImmDouble d) = double $ fromRational d--pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b-pprImm (ImmConstantDiff a b) = pprImm a <> char '-'- <> lparen <> pprImm b <> rparen+pprImm :: Platform -> Imm -> SDoc+pprImm platform = \case+ ImmInt i -> int i+ ImmInteger i -> integer i+ ImmCLbl l -> pdoc platform l+ ImmIndex l i -> pdoc platform l <> char '+' <> int i+ ImmLit s -> s+ ImmFloat f -> float $ fromRational f+ ImmDouble d -> double $ fromRational d+ ImmConstantSum a b -> pprImm platform a <> char '+' <> pprImm platform b+ ImmConstantDiff a b -> pprImm platform a <> char '-' <> lparen <> pprImm platform b <> rparen pprAddr :: Platform -> AddrMode -> SDoc-pprAddr _platform (ImmAddr imm off)- = let pp_imm = pprImm imm+pprAddr platform (ImmAddr imm off)+ = let pp_imm = pprImm platform imm in if (off == 0) then pp_imm@@ -460,7 +460,7 @@ where ppr_disp (ImmInt 0) = empty- ppr_disp imm = pprImm imm+ ppr_disp imm = pprImm platform imm -- | Print section header and appropriate alignment for that section. pprSectionAlign :: NCGConfig -> Section -> SDoc@@ -509,12 +509,12 @@ imm = litToImm lit -- These seem to be common:- ppr_item II8 _ = [text "\t.byte\t" <> pprImm imm]- ppr_item II16 _ = [text "\t.word\t" <> pprImm imm]- ppr_item II32 _ = [text "\t.long\t" <> pprImm imm]+ ppr_item II8 _ = [text "\t.byte\t" <> pprImm platform imm]+ ppr_item II16 _ = [text "\t.word\t" <> pprImm platform imm]+ ppr_item II32 _ = [text "\t.long\t" <> pprImm platform imm] - ppr_item FF32 _ = [text "\t.float\t" <> pprImm imm]- ppr_item FF64 _ = [text "\t.double\t" <> pprImm imm]+ ppr_item FF32 _ = [text "\t.float\t" <> pprImm platform imm]+ ppr_item FF64 _ = [text "\t.double\t" <> pprImm platform imm] ppr_item II64 _ = case platformOS platform of@@ -529,10 +529,10 @@ (fromIntegral (x `shiftR` 32) :: Word32))] _ -> panic "X86.Ppr.ppr_item: no match for II64" | otherwise ->- [text "\t.quad\t" <> pprImm imm]+ [text "\t.quad\t" <> pprImm platform imm] _ | target32Bit platform ->- [text "\t.quad\t" <> pprImm imm]+ [text "\t.quad\t" <> pprImm platform imm] | otherwise -> -- x86_64: binutils can't handle the R_X86_64_PC64 -- relocation type, which means we can't do@@ -547,10 +547,10 @@ case lit of -- A relative relocation: CmmLabelDiffOff _ _ _ _ ->- [text "\t.long\t" <> pprImm imm,+ [text "\t.long\t" <> pprImm platform imm, text "\t.long\t0"] _ ->- [text "\t.quad\t" <> pprImm imm]+ [text "\t.quad\t" <> pprImm platform imm] asmComment :: SDoc -> SDoc@@ -571,8 +571,8 @@ -> panic "pprInstr: NEWBLOCK" UNWIND lbl d- -> asmComment (text "\tunwind = " <> ppr d)- $$ ppr lbl <> colon+ -> asmComment (text "\tunwind = " <> pdoc platform d)+ $$ pdoc platform lbl <> colon LDATA _ _ -> panic "pprInstr: LDATA"@@ -814,14 +814,14 @@ -> pprFormatOpReg (sLit "xchg") format src val JXX cond blockid- -> pprCondInstr (sLit "j") cond (ppr lab)+ -> pprCondInstr (sLit "j") cond (pdoc platform lab) where lab = blockLbl blockid JXX_GBL cond imm- -> pprCondInstr (sLit "j") cond (pprImm imm)+ -> pprCondInstr (sLit "j") cond (pprImm platform imm) JMP (OpImm imm) _- -> text "\tjmp " <> pprImm imm+ -> text "\tjmp " <> pprImm platform imm JMP op _ -> text "\tjmp *" <> pprOperand platform (archWordFormat (target32Bit platform)) op@@ -830,7 +830,7 @@ -> pprInstr platform (JMP op []) CALL (Left imm) _- -> text "\tcall " <> pprImm imm+ -> text "\tcall " <> pprImm platform imm CALL (Right reg) _ -> text "\tcall *" <> pprReg platform (archWordFormat (target32Bit platform)) reg@@ -929,7 +929,7 @@ pprX87Instr _ = panic "X86.Ppr.pprX87Instr: no match" pprDollImm :: Imm -> SDoc- pprDollImm i = text "$" <> pprImm i+ pprDollImm i = text "$" <> pprImm platform i pprOperand :: Platform -> Format -> Operand -> SDoc@@ -954,7 +954,7 @@ = hcat [ pprMnemonic name format, char '$',- pprImm imm,+ pprImm platform imm, comma, pprOperand platform format op1 ]
compiler/GHC/CmmToC.hs view
@@ -91,7 +91,7 @@ blankLine, extern_decls, (if (externallyVisibleCLabel clbl)- then mkFN_ else mkIF_) (ppr clbl) <+> lbrace,+ then mkFN_ else mkIF_) (pprCLabel platform CStyle clbl) <+> lbrace, nest 8 temp_decls, vcat (map (pprBBlock platform) blocks), rbrace ]@@ -110,14 +110,14 @@ (CmmData section (CmmStaticsRaw lbl [CmmString str])) -> pprExternDecl platform lbl $$ hcat [- pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl,+ pprLocalness lbl, pprConstness (isSecConstant section), text "char ", pprCLabel platform CStyle lbl, text "[] = ", pprStringInCStyle str, semi ] (CmmData section (CmmStaticsRaw lbl [CmmUninitialised size])) -> pprExternDecl platform lbl $$ hcat [- pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl,+ pprLocalness lbl, pprConstness (isSecConstant section), text "char ", pprCLabel platform CStyle lbl, brackets (int size), semi ] @@ -153,7 +153,7 @@ = -- TODO: align closures only pprExternDecl platform lbl $$ hcat [ pprLocalness lbl, pprConstness is_ro, text "StgWord"- , space, ppr lbl, text "[]"+ , space, pprCLabel platform CStyle lbl, text "[]" -- See Note [StgWord alignment] , pprAlignment (wordWidth platform) , text "= {" ]@@ -238,7 +238,7 @@ case fn of CmmLit (CmmLabel lbl) | StdCallConv <- cconv ->- pprCall platform (ppr lbl) cconv hresults hargs+ pprCall platform (pprCLabel platform CStyle lbl) cconv hresults hargs -- stdcall functions must be declared with -- a function type, otherwise the C compiler -- doesn't add the @n suffix to the label. We@@ -247,7 +247,7 @@ | CmmNeverReturns <- ret -> pprCall platform cast_fn cconv hresults hargs <> semi | not (isMathFun lbl) ->- pprForeignCall platform (ppr lbl) cconv hresults hargs+ pprForeignCall platform (pprCLabel platform CStyle lbl) cconv hresults hargs _ -> pprCall platform cast_fn cconv hresults hargs <> semi -- for a dynamic call, no declaration is necessary.@@ -281,7 +281,7 @@ CmmCall { cml_target = expr } -> mkJMP_ (pprExpr platform expr) <> semi CmmSwitch arg ids -> pprSwitch platform arg ids - _other -> pprPanic "PprC.pprStmt" (ppr stmt)+ _other -> pprPanic "PprC.pprStmt" (pdoc platform stmt) type Hinted a = (a, ForeignHint) @@ -487,7 +487,7 @@ -> mkW_ <> pprCLabelAddr clbl1 <> char '+' <> int i where- pprCLabelAddr lbl = char '&' <> ppr lbl+ pprCLabelAddr lbl = char '&' <> pprCLabel platform CStyle lbl pprLit1 :: Platform -> CmmLit -> SDoc pprLit1 platform lit = case lit of@@ -1047,7 +1047,7 @@ | not (needsCDecl lbl) = empty | Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz | otherwise =- hcat [ visibility, label_type lbl , lparen, ppr lbl, text ");"+ hcat [ visibility, label_type lbl , lparen, pprCLabel platform CStyle lbl, text ");" -- occasionally useful to see label type -- , text "/* ", pprDebugCLabel lbl, text " */" ]@@ -1070,7 +1070,7 @@ -- we must generate an appropriate prototype for it, so that the C compiler will -- add the @n suffix to the label (#2276) stdcall_decl sz =- text "extern __attribute__((stdcall)) void " <> ppr lbl+ text "extern __attribute__((stdcall)) void " <> pprCLabel platform CStyle lbl <> parens (commafy (replicate (sz `quot` platformWordSizeInBytes platform) (machRep_U_CType platform (wordWidth platform)))) <> semi
compiler/GHC/CmmToLlvm.hs view
@@ -164,7 +164,7 @@ let fixed_cmm = {-# SCC "llvm_fix_regs" #-} fixStgRegisters platform cmm dumpIfSetLlvm Opt_D_dump_opt_cmm "Optimised Cmm"- FormatCMM (pprCmmGroup [fixed_cmm])+ FormatCMM (pprCmmGroup platform [fixed_cmm]) -- generate llvm code from cmm llvmBC <- withClearVars $ genLlvmProc fixed_cmm
compiler/GHC/CmmToLlvm/Base.hs view
@@ -435,7 +435,7 @@ -- Write to output dflags <- getDynFlags out <- getEnv envOutput- let ctx = initSDocContext dflags (Outp.mkCodeStyle Outp.CStyle)+ let ctx = initSDocContext dflags (Outp.PprCode Outp.CStyle) liftIO $ Outp.bufLeftRenderSDoc ctx out sdoc -- Dump, if requested@@ -497,9 +497,9 @@ strCLabel_llvm lbl = do dflags <- getDynFlags platform <- getPlatform- let sdoc = pprCLabel_LLVM platform lbl+ let sdoc = pprCLabel platform CStyle lbl str = Outp.renderWithContext- (initSDocContext dflags (Outp.mkCodeStyle Outp.CStyle))+ (initSDocContext dflags (Outp.PprCode Outp.CStyle)) sdoc return (fsLit str)
compiler/GHC/CmmToLlvm/CodeGen.hs view
@@ -1565,7 +1565,7 @@ else do -- Error. Continue anyway so we can debug the generated ll file. dflags <- getDynFlags- let style = mkCodeStyle CStyle+ let style = PprCode CStyle toString doc = renderWithContext (initSDocContext dflags style) doc cmmToStr = (lines . toString . PprCmm.pprExpr platform) statement $ Comment $ map fsLit $ cmmToStr x
compiler/GHC/Core/Opt/DmdAnal.hs view
@@ -23,6 +23,7 @@ import GHC.Core.Seq ( seqBinds ) import GHC.Utils.Outputable import GHC.Types.Var.Env+import GHC.Types.Var.Set import GHC.Types.Basic import Data.List ( mapAccumL ) import GHC.Core.DataCon@@ -32,6 +33,7 @@ import GHC.Core.Utils import GHC.Core.TyCon import GHC.Core.Type+import GHC.Core.FVs ( exprFreeIds, ruleRhsFreeIds ) import GHC.Core.Coercion ( Coercion, coVarsOfCo ) import GHC.Core.FamInstEnv import GHC.Utils.Misc@@ -359,7 +361,7 @@ = True | Just DataConAppContext{ dcac_dc = dc, dcac_arg_tys = field_tys } <- deepSplitProductType_maybe fam_envs ty- , isUnboxedTupleCon dc+ , isUnboxedTupleDataCon dc = any (\(ty,_) -> scaledThing ty `eqType` realWorldStatePrimTy) field_tys | otherwise = False@@ -552,7 +554,9 @@ -- See Note [Demand signatures are computed for a threshold demand based on idArity] = mkRhsDmd env rhs_arity rhs - (DmdType rhs_fv rhs_dmds rhs_div, rhs') = dmdAnal env rhs_dmd rhs+ (rhs_dmd_ty, rhs') = dmdAnal env rhs_dmd rhs+ DmdType rhs_fv rhs_dmds rhs_div = rhs_dmd_ty+ sig = mkStrictSigForArity rhs_arity (DmdType sig_fv rhs_dmds rhs_div) -- See Note [Aggregated demand for cardinality]@@ -560,10 +564,23 @@ Just bs -> reuseEnv (delVarEnvList rhs_fv bs) Nothing -> rhs_fv + rhs_fv2 = rhs_fv1 `keepAliveDmdEnv` extra_fvs+ -- See Note [Lazy and unleashable free variables]- (lazy_fv, sig_fv) = splitFVs is_thunk rhs_fv1+ (lazy_fv, sig_fv) = splitFVs is_thunk rhs_fv2 is_thunk = not (exprIsHNF rhs) && not (isJoinId id) + -- Find the RHS free vars of the unfoldings and RULES+ -- See Note [Absence analysis for stable unfoldings and RULES]+ extra_fvs = foldr (unionVarSet . ruleRhsFreeIds) unf_fvs $+ idCoreRules id++ unf = realIdUnfolding id+ unf_fvs | isStableUnfolding unf+ , Just unf_body <- maybeUnfoldingTemplate unf+ = exprFreeIds unf_body+ | otherwise = emptyVarSet+ -- | @mkRhsDmd env rhs_arity rhs@ creates a 'CleanDemand' for -- unleashing on the given function's @rhs@, by creating -- a call demand of @rhs_arity@@@ -799,6 +816,43 @@ forward plusInt's demand signature, and all is well (see Note [Newtype arity] in GHC.Core.Opt.Arity)! A small example is the test case NewtypeArity. +Note [Absence analysis for stable unfoldings and RULES]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Ticket #18638 shows that it's really important to do absence analysis+for stable unfoldings. Consider++ g = blah++ f = \x. ...no use of g....+ {- f's stable unfolding is f = \x. ...g... -}++If f is ever inlined we use 'g'. But f's current RHS makes no use+of 'g', so if we don't look at the unfolding we'll mark g as Absent,+and transform to++ g = error "Entered absent value"+ f = \x. ...+ {- f's stable unfolding is f = \x. ...g... -}++Now if f is subsequently inlined, we'll use 'g' and ... disaster.++SOLUTION: if f has a stable unfolding, adjust its DmdEnv (the demands+on its free variables) so that no variable mentioned in its unfolding+is Absent. This is done by the function Demand.keepAliveDmdEnv.++ALSO: do the same for Ids free in the RHS of any RULES for f.++PS: You may wonder how it can be that f's optimised RHS has somehow+discarded 'g', but when f is inlined we /don't/ discard g in the same+way. I think a simple example is+ g = (a,b)+ f = \x. fst g+ {-# INLINE f #-}++Now f's optimised RHS will be \x.a, but if we change g to (error "..")+(since it is apparently Absent) and then inline (\x. fst g) we get+disaster. But regardless, #18638 was a more complicated version of+this, that actually happened in practice. Historical Note [Product demands for function body] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Core/Opt/LiberateCase.hs view
@@ -13,7 +13,7 @@ import GHC.Driver.Session import GHC.Core-import GHC.Core.Unfold ( couldBeSmallEnoughToInline )+import GHC.Core.Unfold import GHC.Builtin.Types ( unitDataConId ) import GHC.Types.Id import GHC.Types.Var.Env@@ -104,13 +104,24 @@ -} liberateCase :: DynFlags -> CoreProgram -> CoreProgram-liberateCase dflags binds = do_prog (initEnv dflags) binds+liberateCase dflags binds = do_prog (initLiberateCaseEnv dflags) binds where do_prog _ [] = [] do_prog env (bind:binds) = bind' : do_prog env' binds where (env', bind') = libCaseBind env bind ++initLiberateCaseEnv :: DynFlags -> LibCaseEnv+initLiberateCaseEnv dflags = LibCaseEnv+ { lc_threshold = liberateCaseThreshold dflags+ , lc_uf_opts = unfoldingOpts dflags+ , lc_lvl = 0+ , lc_lvl_env = emptyVarEnv+ , lc_rec_env = emptyVarEnv+ , lc_scruts = []+ }+ {- ************************************************************************ * *@@ -152,9 +163,9 @@ -- size, build a fake binding (let { dup_pairs } in (), -- and find the size of that -- See Note [Small enough]- small_enough = case bombOutSize env of+ small_enough = case lc_threshold env of Nothing -> True -- Infinity- Just size -> couldBeSmallEnoughToInline (lc_dflags env) size $+ Just size -> couldBeSmallEnoughToInline (lc_uf_opts env) size $ Let (Rec dup_pairs) (Var unitDataConId) ok_pair (id,_)@@ -392,23 +403,28 @@ data LibCaseEnv = LibCaseEnv {- lc_dflags :: DynFlags,+ lc_threshold :: Maybe Int,+ -- ^ Bomb-out size for deciding if potential liberatees are too+ -- big. - lc_lvl :: LibCaseLevel, -- Current level+ lc_uf_opts :: UnfoldingOpts,+ -- ^ Unfolding options++ lc_lvl :: LibCaseLevel, -- ^ Current level -- The level is incremented when (and only when) going -- inside the RHS of a (sufficiently small) recursive -- function. lc_lvl_env :: IdEnv LibCaseLevel,- -- Binds all non-top-level in-scope Ids (top-level and+ -- ^ Binds all non-top-level in-scope Ids (top-level and -- imported things have a level of zero) lc_rec_env :: IdEnv CoreBind,- -- Binds *only* recursively defined ids, to their own+ -- ^ Binds *only* recursively defined ids, to their own -- binding group, and *only* in their own RHSs lc_scruts :: [(Id, LibCaseLevel, LibCaseLevel)]- -- Each of these Ids was scrutinised by an enclosing+ -- ^ Each of these Ids was scrutinised by an enclosing -- case expression, at a level deeper than its binding -- level. --@@ -426,17 +442,3 @@ -- although that'd be unusual: -- case x of { (a,b) -> ....(case x of ...) .. } }--initEnv :: DynFlags -> LibCaseEnv-initEnv dflags- = LibCaseEnv { lc_dflags = dflags,- lc_lvl = 0,- lc_lvl_env = emptyVarEnv,- lc_rec_env = emptyVarEnv,- lc_scruts = [] }---- Bomb-out size for deciding if--- potential liberatees are too big.--- (passed in from cmd-line args)-bombOutSize :: LibCaseEnv -> Maybe Int-bombOutSize = liberateCaseThreshold . lc_dflags
compiler/GHC/Core/Opt/Pipeline.hs view
@@ -141,6 +141,7 @@ static_args = gopt Opt_StaticArgumentTransformation dflags rules_on = gopt Opt_EnableRewriteRules dflags eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags+ pre_inline_on = gopt Opt_SimplPreInlining dflags ww_on = gopt Opt_WorkerWrapper dflags static_ptrs = xopt LangExt.StaticPointers dflags @@ -154,10 +155,13 @@ base_mode = SimplMode { sm_phase = panic "base_mode" , sm_names = [] , sm_dflags = dflags+ , sm_uf_opts = unfoldingOpts dflags , sm_rules = rules_on , sm_eta_expand = eta_expand_on , sm_inline = True- , sm_case_case = True }+ , sm_case_case = True+ , sm_pre_inline = pre_inline_on+ } simpl_phase phase name iter = CoreDoPasses@@ -311,33 +315,38 @@ runWhen do_float_in CoreDoFloatInwards, + simplify "final", -- Final tidy-up+ maybe_rule_check FinalPhase, + -------- After this we have -O2 passes -----------------+ -- None of them run with -O+ -- Case-liberation for -O2. This should be after -- strictness analysis and the simplification which follows it.- runWhen liberate_case (CoreDoPasses [- CoreLiberateCase,- simplify "post-liberate-case"- ]), -- Run the simplifier after LiberateCase to vastly- -- reduce the possibility of shadowing- -- Reason: see Note [Shadowing] in GHC.Core.Opt.SpecConstr+ runWhen liberate_case $ CoreDoPasses+ [ CoreLiberateCase, simplify "post-liberate-case" ],+ -- Run the simplifier after LiberateCase to vastly+ -- reduce the possibility of shadowing+ -- Reason: see Note [Shadowing] in GHC.Core.Opt.SpecConstr - runWhen spec_constr CoreDoSpecConstr,+ runWhen spec_constr $ CoreDoPasses+ [ CoreDoSpecConstr, simplify "post-spec-constr"],+ -- See Note [Simplify after SpecConstr] maybe_rule_check FinalPhase, - runWhen late_specialise- (CoreDoPasses [ CoreDoSpecialising- , simplify "post-late-spec"]),+ runWhen late_specialise $ CoreDoPasses+ [ CoreDoSpecialising, simplify "post-late-spec"], -- LiberateCase can yield new CSE opportunities because it peels -- off one layer of a recursive function (concretely, I saw this -- in wheel-sieve1), and I'm guessing that SpecConstr can too -- And CSE is a very cheap pass. So it seems worth doing here.- runWhen ((liberate_case || spec_constr) && cse) CoreCSE,+ runWhen ((liberate_case || spec_constr) && cse) $ CoreDoPasses+ [ CoreCSE, simplify "post-final-cse" ], - -- Final clean-up simplification:- simplify "final",+ --------- End of -O2 passes -------------- runWhen late_dmd_anal $ CoreDoPasses ( dmd_cpr_ww ++ [simplify "post-late-ww"]@@ -405,6 +414,27 @@ But watch out: list fusion can prevent floating. So use phase control to switch off those rules until after floating.++Note [Simplify after SpecConstr]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We want to run the simplifier after SpecConstr, and before late-Specialise,+for two reasons, both shown up in test perf/compiler/T16473,+with -O2 -flate-specialise++1. I found that running late-Specialise after SpecConstr, with no+ simplification in between meant that the carefullly constructed+ SpecConstr rule never got to fire. (It was something like+ lvl = f a -- Arity 1+ ....g lvl....+ SpecConstr specialised g for argument lvl; but Specialise then+ specialised lvl = f a to lvl = $sf, and inlined. Or something like+ that.)++2. Specialise relies on unfoldings being available for top-level dictionary+ bindings; but SpecConstr kills them all! The Simplifer restores them.++This extra run of the simplifier has a cost, but this is only with -O2.+ ************************************************************************ * *
compiler/GHC/Core/Opt/Simplify.hs view
@@ -16,6 +16,8 @@ import GHC.Platform import GHC.Driver.Session import GHC.Driver.Ppr+import GHC.Driver.Config+import GHC.Core.SimpleOpt ( exprIsConApp_maybe ) import GHC.Core.Opt.Simplify.Monad import GHC.Core.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst ) import GHC.Core.Opt.Simplify.Env@@ -34,7 +36,7 @@ import GHC.Core.FamInstEnv ( topNormaliseType_maybe ) import GHC.Core.DataCon ( DataCon, dataConWorkId, dataConRepStrictness- , dataConRepArgTys, isUnboxedTupleCon+ , dataConRepArgTys, isUnboxedTupleDataCon , StrictnessMark (..) ) import GHC.Core.Opt.Monad ( Tick(..), SimplMode(..) ) import GHC.Core@@ -46,11 +48,12 @@ import GHC.Core.Ppr ( pprCoreExpr ) import GHC.Types.Unique ( hasKey ) import GHC.Core.Unfold+import GHC.Core.Unfold.Make import GHC.Core.Utils import GHC.Core.Opt.Arity ( ArityType(..), arityTypeArity, isBotArityType+ , pushCoTyArg, pushCoValArg , idArityType, etaExpandAT )-import GHC.Core.SimpleOpt ( pushCoTyArg, pushCoValArg- , joinPointBinding_maybe, joinPointBindings_maybe )+import GHC.Core.SimpleOpt ( joinPointBinding_maybe, joinPointBindings_maybe ) import GHC.Core.FVs ( mkRuleInfo ) import GHC.Core.Rules ( lookupRule, getRules, initRuleOpts ) import GHC.Types.Basic@@ -315,7 +318,7 @@ ; let rhs_cont = mkRhsStop (substTy body_env (exprType body)) ; (body_floats0, body0) <- {-#SCC "simplExprF" #-} simplExprF body_env body rhs_cont - -- Never float join-floats out of a non-join let-binding+ -- Never float join-floats out of a non-join let-binding (which this is) -- So wrap the body in the join-floats right now -- Hence: body_floats1 consists only of let-floats ; let (body_floats1, body1) = wrapJoinFloatsX body_floats0 body0@@ -341,7 +344,7 @@ else -- Do type-abstraction first {-#SCC "simplLazyBind-type-abstraction-first" #-} do { tick LetFloatFromLet- ; (poly_binds, body3) <- abstractFloats (seDynFlags env) top_lvl+ ; (poly_binds, body3) <- abstractFloats (seUnfoldingOpts env) top_lvl tvs' body_floats2 body2 ; let floats = foldl' extendFloats (emptyFloats env) poly_binds ; rhs' <- mkLam env tvs' body3 rhs_cont@@ -675,7 +678,7 @@ -- Now something very like completeBind, -- but without the postInlineUnconditionally part ; (arity_type, expr2) <- tryEtaExpandRhs mode var expr1- ; unf <- mkLetUnfolding (sm_dflags mode) top_lvl InlineRhs var expr2+ ; unf <- mkLetUnfolding (sm_uf_opts mode) top_lvl InlineRhs var expr2 ; let final_id = addLetBndrInfo var arity_type unf bind = NonRec final_id expr2@@ -1150,8 +1153,8 @@ simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion simplCoercion env co- = do { dflags <- getDynFlags- ; let opt_co = optCoercion dflags (getTCvSubst env) co+ = do { opts <- getOptCoercionOpts+ ; let opt_co = optCoercion opts (getTCvSubst env) co ; seqCo opt_co `seq` return opt_co } -----------------------------------@@ -1411,25 +1414,23 @@ -- type of the hole changes (#16312) -- (f |> co) e ===> (f (e |> co1)) |> co2- -- where co :: (s1->s2) ~ (t1~t2)+ -- where co :: (s1->s2) ~ (t1->t2) -- co1 :: t1 ~ s1 -- co2 :: s2 ~ t2 addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se , sc_dup = dup, sc_cont = tail })- | Just (co1, m_co2) <- pushCoValArg co- , let new_ty = coercionRKind co1- , not (isTypeLevPoly new_ty) -- Without this check, we get a lev-poly arg- -- See Note [Levity polymorphism invariants] in GHC.Core- -- test: typecheck/should_run/EtaExpandLevPoly+ | Just (m_co1, m_co2) <- pushCoValArg co+ , levity_ok m_co1 = {-#SCC "addCoerce-pushCoValArg" #-} do { tail' <- addCoerceM m_co2 tail- ; if isReflCo co1- then return (cont { sc_cont = tail'- , sc_hole_ty = coercionLKind co })+ ; case m_co1 of {+ MRefl -> return (cont { sc_cont = tail'+ , sc_hole_ty = coercionLKind co }) ; -- Avoid simplifying if possible; -- See Note [Avoiding exponential behaviour]- else do- { (dup', arg_se', arg') <- simplArg env dup arg_se arg++ MCo co1 ->+ do { (dup', arg_se', arg') <- simplArg env dup arg_se arg -- When we build the ApplyTo we can't mix the OutCoercion -- 'co' with the InExpr 'arg', so we simplify -- to make it all consistent. It's a bit messy.@@ -1439,7 +1440,7 @@ , sc_env = arg_se' , sc_dup = dup' , sc_cont = tail'- , sc_hole_ty = coercionLKind co }) } }+ , sc_hole_ty = coercionLKind co }) } } } addCoerce co cont | isReflexiveCo co = return cont -- Having this at the end makes a huge@@ -1447,6 +1448,13 @@ -- See Note [Optimising reflexivity] | otherwise = return (CastIt co cont) + levity_ok :: MCoercionR -> Bool+ levity_ok MRefl = True+ levity_ok (MCo co) = not $ isTypeLevPoly $ coercionRKind co+ -- Without this check, we get a lev-poly arg+ -- See Note [Levity polymorphism invariants] in GHC.Core+ -- test: typecheck/should_run/EtaExpandLevPoly+ simplArg :: SimplEnv -> DupFlag -> StaticEnv -> CoreExpr -> SimplM (DupFlag, StaticEnv, OutExpr) simplArg env dup_flag arg_env arg@@ -1909,7 +1917,7 @@ log_inlining $ sep [text "Inlining done:", nest 4 (ppr var)] | otherwise- = liftIO $ log_inlining $+ = log_inlining $ sep [text "Inlining done: " <> ppr var, nest 4 (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding), text "Cont: " <+> ppr cont])]@@ -2632,7 +2640,7 @@ -- -- As an illustration, consider the following -- case[Many] case[1] of { C x -> C x } of { C x -> (x, x) }- -- Where C :: A #-> T is linear+ -- Where C :: A %1 -> T is linear -- If we were to produce a case[1], like the inner case, we would get -- case[1] of { C x -> (x, x) } -- Which is ill-typed with respect to linearity. So it needs to be a@@ -2957,7 +2965,7 @@ addEvals scrut con vs -- Deal with seq# applications | Just scr <- scrut- , isUnboxedTupleCon con+ , isUnboxedTupleDataCon con , [s,x] <- vs -- Use stripNArgs rather than collectArgsTicks to avoid building -- a list of arguments only to throw it away immediately.@@ -3008,7 +3016,7 @@ ; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr scrut, ppr con_app]) ; return env2 } where- mk_simple_unf = mkSimpleUnfolding (seDynFlags env)+ mk_simple_unf = mkSimpleUnfolding (seUnfoldingOpts env) addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv addBinderUnfolding env bndr unf@@ -3111,7 +3119,7 @@ knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont = do { (floats1, env1) <- bind_args env bs dc_args- ; (floats2, env2) <- bind_case_bndr env1+ ; (floats2, env2) <- bind_case_bndr env1 ; (floats3, expr') <- simplExprF env2 rhs cont ; case dc_floats of [] ->@@ -3237,6 +3245,7 @@ altsWouldDup (alt:alts) | is_bot_alt alt = altsWouldDup alts | otherwise = not (all is_bot_alt alts)+ -- otherwise case: first alt is non-bot, so all the rest must be bot where is_bot_alt (_,_,rhs) = exprIsDeadEnd rhs @@ -3431,7 +3440,8 @@ = return (jfloats, (con, bndrs', rhs')) | otherwise- = do { let rhs_ty' = exprType rhs'+ = do { simpl_opts <- initSimpleOpts <$> getDynFlags+ ; let rhs_ty' = exprType rhs' scrut_ty = idType case_bndr case_bndr_w_unf = case con of@@ -3439,7 +3449,7 @@ DataAlt dc -> setIdUnfolding case_bndr unf where -- See Note [Case binders and join points]- unf = mkInlineUnfolding rhs+ unf = mkInlineUnfolding simpl_opts rhs rhs = mkConApp2 dc (tyConAppArgs scrut_ty) bndrs' LitAlt {} -> WARN( True, text "mkDupableAlt"@@ -3778,14 +3788,14 @@ | isExitJoinId id = return noUnfolding -- See Note [Do not inline exit join points] in GHC.Core.Opt.Exitify | otherwise- = mkLetUnfolding (seDynFlags env) top_lvl InlineRhs id new_rhs+ = mkLetUnfolding (seUnfoldingOpts env) top_lvl InlineRhs id new_rhs --------------------mkLetUnfolding :: DynFlags -> TopLevelFlag -> UnfoldingSource+mkLetUnfolding :: UnfoldingOpts -> TopLevelFlag -> UnfoldingSource -> InId -> OutExpr -> SimplM Unfolding-mkLetUnfolding dflags top_lvl src id new_rhs+mkLetUnfolding uf_opts top_lvl src id new_rhs = is_bottoming `seq` -- See Note [Force bottoming field]- return (mkUnfolding dflags src is_top_lvl is_bottoming new_rhs)+ return (mkUnfolding uf_opts src is_top_lvl is_bottoming new_rhs) -- We make an unfolding *even for loop-breakers*. -- Reason: (a) It might be useful to know that they are WHNF -- (b) In GHC.Iface.Tidy we currently assume that, if we want to@@ -3848,14 +3858,14 @@ -- See Note [Top-level flag on inline rules] in GHC.Core.Unfold _other -- Happens for INLINABLE things- -> mkLetUnfolding dflags top_lvl src id expr' }+ -> mkLetUnfolding uf_opts top_lvl src id expr' } -- If the guidance is UnfIfGoodArgs, this is an INLINABLE -- unfolding, and we need to make sure the guidance is kept up -- to date with respect to any changes in the unfolding. | otherwise -> return noUnfolding -- Discard unstable unfoldings where- dflags = seDynFlags env+ uf_opts = seUnfoldingOpts env is_top_lvl = isTopLevel top_lvl act = idInlineActivation id unf_env = updMode (updModeForStableUnfoldings act) env
compiler/GHC/Core/Opt/Simplify/Env.hs view
@@ -8,7 +8,7 @@ module GHC.Core.Opt.Simplify.Env ( -- * The simplifier mode- setMode, getMode, updMode, seDynFlags,+ setMode, getMode, updMode, seDynFlags, seUnfoldingOpts, -- * Environments SimplEnv(..), pprSimplEnv, -- Temp not abstract@@ -52,6 +52,7 @@ import GHC.Core import GHC.Core.Utils import GHC.Core.Multiplicity ( scaleScaled )+import GHC.Core.Unfold import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Var.Set@@ -309,6 +310,10 @@ seDynFlags :: SimplEnv -> DynFlags seDynFlags env = sm_dflags (seMode env) +seUnfoldingOpts :: SimplEnv -> UnfoldingOpts+seUnfoldingOpts env = sm_uf_opts (seMode env)++ setMode :: SimplMode -> SimplEnv -> SimplEnv setMode mode env = env { seMode = mode } @@ -591,7 +596,7 @@ addJoinFlts = appOL mkRecFloats :: SimplFloats -> SimplFloats--- Flattens the floats from env2 into a single Rec group,+-- Flattens the floats into a single Rec group, -- They must either all be lifted LetFloats or all JoinFloats mkRecFloats floats@(SimplFloats { sfLetFloats = LetFloats bs ff , sfJoinFloats = jbs@@ -948,7 +953,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider a join point which is linear in its variable, in some context E: -E[join j :: a #-> a+E[join j :: a %1 -> a j x = x in case v of A -> j 'x'@@ -956,7 +961,7 @@ The simplifier changes to: -join j :: a #-> a+join j :: a %1 -> a j x = E[x] in case v of A -> j 'x'
compiler/GHC/Core/Opt/Simplify/Monad.hs view
@@ -10,7 +10,7 @@ -- The monad SimplM, initSmpl, traceSmpl,- getSimplRules, getFamEnvs,+ getSimplRules, getFamEnvs, getOptCoercionOpts, -- Unique supply MonadUnique(..), newId, newJoinId,@@ -31,8 +31,10 @@ import GHC.Core.FamInstEnv ( FamInstEnv ) import GHC.Core ( RuleEnv(..) ) import GHC.Core.Utils ( mkLamTypes )+import GHC.Core.Coercion.Opt import GHC.Types.Unique.Supply import GHC.Driver.Session+import GHC.Driver.Config import GHC.Core.Opt.Monad import GHC.Utils.Outputable import GHC.Data.FastString@@ -78,10 +80,14 @@ data SimplTopEnv = STE { st_flags :: DynFlags- , st_max_ticks :: IntWithInf -- Max #ticks in this simplifier run+ , st_max_ticks :: IntWithInf -- ^ Max #ticks in this simplifier run , st_rules :: RuleEnv- , st_fams :: (FamInstEnv, FamInstEnv) }+ , st_fams :: (FamInstEnv, FamInstEnv) + , st_co_opt_opts :: !OptCoercionOpts+ -- ^ Coercion optimiser options+ }+ initSmpl :: DynFlags -> RuleEnv -> (FamInstEnv, FamInstEnv) -> UniqSupply -- No init count; set to 0 -> Int -- Size of the bindings, used to limit@@ -93,9 +99,12 @@ = do (result, _, count) <- unSM m env us (zeroSimplCount dflags) return (result, count) where- env = STE { st_flags = dflags, st_rules = rules+ env = STE { st_flags = dflags+ , st_rules = rules , st_max_ticks = computeMaxTicks dflags size- , st_fams = fam_envs }+ , st_fams = fam_envs+ , st_co_opt_opts = initOptCoercionOpts dflags+ } computeMaxTicks :: DynFlags -> Int -> IntWithInf -- Compute the max simplifier ticks as@@ -194,6 +203,9 @@ getFamEnvs :: SimplM (FamInstEnv, FamInstEnv) getFamEnvs = SM (\st_env us sc -> return (st_fams st_env, us, sc))++getOptCoercionOpts :: SimplM OptCoercionOpts+getOptCoercionOpts = SM (\st_env us sc -> return (st_co_opt_opts st_env, us, sc)) newId :: FastString -> Mult -> Type -> SimplM Id newId fs w ty = do uniq <- getUniqueM
compiler/GHC/Core/Opt/Simplify/Utils.hs view
@@ -53,6 +53,7 @@ import GHC.Core.Utils import GHC.Core.Opt.Arity import GHC.Core.Unfold+import GHC.Core.Unfold.Make import GHC.Types.Name import GHC.Types.Id import GHC.Types.Id.Info@@ -862,15 +863,21 @@ = mkSimplEnv $ SimplMode { sm_names = ["GHCi"] , sm_phase = InitialPhase , sm_dflags = dflags+ , sm_uf_opts = uf_opts , sm_rules = rules_on , sm_inline = False+ -- Do not do any inlining, in case we expose some+ -- unboxed tuple stuff that confuses the bytecode+ -- interpreter , sm_eta_expand = eta_expand_on- , sm_case_case = True }+ , sm_case_case = True+ , sm_pre_inline = pre_inline_on+ } where rules_on = gopt Opt_EnableRewriteRules dflags eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags- -- Do not do any inlining, in case we expose some unboxed- -- tuple stuff that confuses the bytecode interpreter+ pre_inline_on = gopt Opt_SimplPreInlining dflags+ uf_opts = unfoldingOpts dflags updModeForStableUnfoldings :: Activation -> SimplMode -> SimplMode -- See Note [Simplifying inside stable unfoldings]@@ -1256,7 +1263,7 @@ , occ_int_cxt = IsInteresting } = canInlineInLam rhs one_occ _ = False - pre_inline_unconditionally = gopt Opt_SimplPreInlining (seDynFlags env)+ pre_inline_unconditionally = sm_pre_inline mode mode = getMode env active = isActive (sm_phase mode) (inlinePragmaActivation inline_prag) -- See Note [pre/postInlineUnconditionally in gentle mode]@@ -1370,7 +1377,7 @@ -> n_br < 100 -- See Note [Suppress exponential blowup] - && smallEnoughToInline dflags unfolding -- Small enough to dup+ && smallEnoughToInline uf_opts unfolding -- Small enough to dup -- ToDo: consider discount on smallEnoughToInline if int_cxt is true -- -- NB: Do NOT inline arbitrarily big things, even if occ_n_br=1@@ -1416,7 +1423,7 @@ where unfolding = idUnfolding bndr- dflags = seDynFlags env+ uf_opts = seUnfoldingOpts env active = isActive (sm_phase (getMode env)) (idInlineActivation bndr) -- See Note [pre/postInlineUnconditionally in gentle mode] @@ -1908,9 +1915,9 @@ which is obviously bogus. -} -abstractFloats :: DynFlags -> TopLevelFlag -> [OutTyVar] -> SimplFloats+abstractFloats :: UnfoldingOpts -> TopLevelFlag -> [OutTyVar] -> SimplFloats -> OutExpr -> SimplM ([OutBind], OutExpr)-abstractFloats dflags top_lvl main_tvs floats body+abstractFloats uf_opts top_lvl main_tvs floats body = ASSERT( notNull body_floats ) ASSERT( isNilOL (sfJoinFloats floats) ) do { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats@@ -1986,7 +1993,7 @@ = (poly_id `setIdUnfolding` unf, poly_rhs) where poly_rhs = mkLams tvs_here rhs- unf = mkUnfolding dflags InlineRhs is_top_lvl False poly_rhs+ unf = mkUnfolding uf_opts InlineRhs is_top_lvl False poly_rhs -- We want the unfolding. Consider -- let
compiler/GHC/Core/Opt/SpecConstr.hs view
@@ -21,7 +21,7 @@ import GHC.Core import GHC.Core.Subst import GHC.Core.Utils-import GHC.Core.Unfold ( couldBeSmallEnoughToInline )+import GHC.Core.Unfold import GHC.Core.FVs ( exprsFreeVarsList ) import GHC.Core.Opt.Monad import GHC.Types.Literal ( litIsLifted )@@ -783,6 +783,7 @@ -} data ScEnv = SCE { sc_dflags :: DynFlags,+ sc_uf_opts :: !UnfoldingOpts, -- ^ Unfolding options sc_module :: !Module, sc_size :: Maybe Int, -- Size threshold -- Nothing => no limit@@ -835,6 +836,7 @@ initScEnv :: DynFlags -> Module -> ScEnv initScEnv dflags this_mod = SCE { sc_dflags = dflags,+ sc_uf_opts = unfoldingOpts dflags, sc_module = this_mod, sc_size = specConstrThreshold dflags, sc_count = specConstrCount dflags,@@ -1364,7 +1366,7 @@ scTopBind env body_usage (Rec prs) | Just threshold <- sc_size env , not force_spec- , not (all (couldBeSmallEnoughToInline (sc_dflags env) threshold) rhss)+ , not (all (couldBeSmallEnoughToInline (sc_uf_opts env) threshold) rhss) -- No specialisation = -- pprTrace "scTopBind: nospec" (ppr bndrs) $ do { (rhs_usgs, rhss') <- mapAndUnzipM (scExpr env) rhss
compiler/GHC/Core/Opt/Specialise.hs view
@@ -21,21 +21,21 @@ import GHC.Core.Type hiding( substTy, extendTvSubstList ) import GHC.Core.Multiplicity import GHC.Core.Predicate-import GHC.Unit.Module( Module, HasModule(..) )+import GHC.Unit.Module( Module ) import GHC.Core.Coercion( Coercion ) import GHC.Core.Opt.Monad import qualified GHC.Core.Subst as Core-import GHC.Core.Unfold+import GHC.Core.Unfold.Make import GHC.Types.Var ( isLocalVar ) import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Core import GHC.Core.Rules-import GHC.Core.SimpleOpt ( collectBindersPushingCo ) import GHC.Core.Utils ( exprIsTrivial, getIdFromTrivialExpr_maybe , mkCast, exprType ) import GHC.Core.FVs-import GHC.Core.Opt.Arity ( etaExpandToJoinPointRule )+import GHC.Core.Opt.Arity ( collectBindersPushingCo+ , etaExpandToJoinPointRule ) import GHC.Types.Unique.Supply import GHC.Types.Name import GHC.Types.Id.Make ( voidArgId, voidPrimId )@@ -47,16 +47,14 @@ import GHC.Data.Bag import GHC.Driver.Session import GHC.Driver.Ppr+import GHC.Driver.Config import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Data.FastString-import GHC.Utils.Monad.State import GHC.Types.Unique.DFM import GHC.Core.TyCo.Rep (TyCoBinder (..)) -import Control.Monad- {- ************************************************************************ * *@@ -590,29 +588,30 @@ , mg_binds = binds }) = do { dflags <- getDynFlags + -- We need to start with a Subst that knows all the things+ -- that are in scope, so that the substitution engine doesn't+ -- accidentally re-use a unique that's already in use+ -- Easiest thing is to do it all at once, as if all the top-level+ -- decls were mutually recursive+ ; let top_env = SE { se_subst = Core.mkEmptySubst $ mkInScopeSet $ mkVarSet $+ bindersOfBinds binds+ , se_interesting = emptyVarSet+ , se_module = this_mod+ , se_dflags = dflags }++ go [] = return ([], emptyUDs)+ go (bind:binds) = do (binds', uds) <- go binds+ (bind', uds') <- specBind top_env bind uds+ return (bind' ++ binds', uds')+ -- Specialise the bindings of this module- ; (binds', uds) <- runSpecM dflags this_mod (go binds)+ ; (binds', uds) <- runSpecM (go binds) - ; (spec_rules, spec_binds) <- specImports dflags this_mod top_env- local_rules uds+ ; (spec_rules, spec_binds) <- specImports top_env local_rules uds ; return (guts { mg_binds = spec_binds ++ binds' , mg_rules = spec_rules ++ local_rules }) }- where- -- We need to start with a Subst that knows all the things- -- that are in scope, so that the substitution engine doesn't- -- accidentally re-use a unique that's already in use- -- Easiest thing is to do it all at once, as if all the top-level- -- decls were mutually recursive- top_env = SE { se_subst = Core.mkEmptySubst $ mkInScopeSet $ mkVarSet $- bindersOfBinds binds- , se_interesting = emptyVarSet } - go [] = return ([], emptyUDs)- go (bind:binds) = do (binds', uds) <- go binds- (bind', uds') <- specBind top_env bind uds- return (bind' ++ binds', uds')- {- Note [Wrap bindings returned by specImports] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -641,13 +640,13 @@ * * ********************************************************************* -} -specImports :: DynFlags -> Module -> SpecEnv+specImports :: SpecEnv -> [CoreRule] -> UsageDetails -> CoreM ([CoreRule], [CoreBind])-specImports dflags this_mod top_env local_rules+specImports top_env local_rules (MkUD { ud_binds = dict_binds, ud_calls = calls })- | not $ gopt Opt_CrossModuleSpecialise dflags+ | not $ gopt Opt_CrossModuleSpecialise (se_dflags top_env) -- See Note [Disabling cross-module specialisation] = return ([], wrapDictBinds dict_binds []) @@ -655,8 +654,7 @@ = do { hpt_rules <- getRuleBase ; let rule_base = extendRuleBaseList hpt_rules local_rules - ; (spec_rules, spec_binds) <- spec_imports dflags this_mod top_env- [] rule_base+ ; (spec_rules, spec_binds) <- spec_imports top_env [] rule_base dict_binds calls -- Don't forget to wrap the specialized bindings with@@ -672,9 +670,7 @@ } -- | Specialise a set of calls to imported bindings-spec_imports :: DynFlags- -> Module- -> SpecEnv -- Passed in so that all top-level Ids are in scope+spec_imports :: SpecEnv -- Passed in so that all top-level Ids are in scope -> [Id] -- Stack of imported functions being specialised -- See Note [specImport call stack] -> RuleBase -- Rules from this module and the home package@@ -684,8 +680,7 @@ -> CallDetails -- Calls for imported things -> CoreM ( [CoreRule] -- New rules , [CoreBind] ) -- Specialised bindings-spec_imports dflags this_mod top_env- callers rule_base dict_binds calls+spec_imports top_env callers rule_base dict_binds calls = do { let import_calls = dVarEnvElts calls -- ; debugTraceMsg (text "specImports {" <+> -- vcat [ text "calls:" <+> ppr import_calls@@ -699,16 +694,13 @@ go _ [] = return ([], []) go rb (cis : other_calls) = do { -- debugTraceMsg (text "specImport {" <+> ppr cis)- ; (rules1, spec_binds1) <- spec_import dflags this_mod top_env- callers rb dict_binds cis+ ; (rules1, spec_binds1) <- spec_import top_env callers rb dict_binds cis -- ; debugTraceMsg (text "specImport }" <+> ppr cis) ; (rules2, spec_binds2) <- go (extendRuleBaseList rb rules1) other_calls ; return (rules1 ++ rules2, spec_binds1 ++ spec_binds2) } -spec_import :: DynFlags- -> Module- -> SpecEnv -- Passed in so that all top-level Ids are in scope+spec_import :: SpecEnv -- Passed in so that all top-level Ids are in scope -> [Id] -- Stack of imported functions being specialised -- See Note [specImport call stack] -> RuleBase -- Rules from this module@@ -717,8 +709,7 @@ -> CallInfoSet -- Imported function and calls for it -> CoreM ( [CoreRule] -- New rules , [CoreBind] ) -- Specialised bindings-spec_import dflags this_mod top_env callers- rb dict_binds cis@(CIS fn _)+spec_import top_env callers rb dict_binds cis@(CIS fn _) | isIn "specImport" fn callers = return ([], []) -- No warning. This actually happens all the time -- when specialising a recursive function, because@@ -729,8 +720,7 @@ = do { -- debugTraceMsg (text "specImport:no valid calls") ; return ([], []) } - | wantSpecImport dflags unfolding- , Just rhs <- maybeUnfoldingTemplate unfolding+ | Just rhs <- canSpecImport dflags fn = do { -- Get rules from the external package state -- We keep doing this in case we "page-fault in" -- more rules as we go along@@ -742,8 +732,8 @@ ; (rules1, spec_pairs, MkUD { ud_binds = dict_binds1, ud_calls = new_calls }) <- do { -- debugTraceMsg (text "specImport1" <+> vcat [ppr fn, ppr good_calls, ppr rhs])- ; runSpecM dflags this_mod $- specCalls (Just this_mod) top_env rules_for_fn good_calls fn rhs }+ ; runSpecM $+ specCalls True top_env rules_for_fn good_calls fn rhs } ; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs] -- After the rules kick in we may get recursion, but -- we rely on a global GlomBinds to sort that out later@@ -751,7 +741,7 @@ -- Now specialise any cascaded calls -- ; debugTraceMsg (text "specImport 2" <+> (ppr fn $$ ppr rules1 $$ ppr spec_binds1))- ; (rules2, spec_binds2) <- spec_imports dflags this_mod top_env+ ; (rules2, spec_binds2) <- spec_imports top_env (fn:callers) (extendRuleBaseList rb rules1) (dict_binds `unionBags` dict_binds1)@@ -767,11 +757,34 @@ ; return ([], [])} where- unfolding = realIdUnfolding fn -- We want to see the unfolding even for loop breakers+ dflags = se_dflags top_env good_calls = filterCalls cis dict_binds -- SUPER IMPORTANT! Drop calls that (directly or indirectly) refer to fn -- See Note [Avoiding loops in specImports] +canSpecImport :: DynFlags -> Id -> Maybe CoreExpr+-- See Note [Specialise imported INLINABLE things]+canSpecImport dflags fn+ | CoreUnfolding { uf_src = src, uf_tmpl = rhs } <- unf+ , isStableSource src+ = Just rhs -- By default, specialise only imported things that have a stable+ -- unfolding; that is, have an INLINE or INLINABLE pragma+ -- Specialise even INLINE things; it hasn't inlined yet,+ -- so perhaps it never will. Moreover it may have calls+ -- inside it that we want to specialise++ -- CoreUnfolding case does /not/ include DFunUnfoldings;+ -- We only specialise DFunUnfoldings with -fspecialise-aggressively+ -- See Note [Do not specialise imported DFuns]++ | gopt Opt_SpecialiseAggressively dflags+ = maybeUnfoldingTemplate unf -- With -fspecialise-aggressively, specialise anything+ -- with an unfolding, stable or not, DFun or not++ | otherwise = Nothing+ where+ unf = realIdUnfolding fn -- We want to see the unfolding even for loop breakers+ -- | Returns whether or not to show a missed-spec warning. -- If -Wall-missed-specializations is on, show the warning. -- Otherwise, if -Wmissed-specializations is on, only show a warning@@ -796,24 +809,47 @@ , whenPprDebug (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn)) , text "Probable fix: add INLINABLE pragma on" <+> quotes (ppr fn) ]) -wantSpecImport :: DynFlags -> Unfolding -> Bool--- See Note [Specialise imported INLINABLE things]-wantSpecImport dflags unf- = case unf of- NoUnfolding -> False- BootUnfolding -> False- OtherCon {} -> False- DFunUnfolding {} -> True- CoreUnfolding { uf_src = src, uf_guidance = _guidance }- | gopt Opt_SpecialiseAggressively dflags -> True- | isStableSource src -> True- -- Specialise even INLINE things; it hasn't inlined yet,- -- so perhaps it never will. Moreover it may have calls- -- inside it that we want to specialise- | otherwise -> False -- Stable, not INLINE, hence INLINABLE -{- Note [Avoiding loops in specImports]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++{- Note [Do not specialise imported DFuns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Ticket #18223 shows that specialising calls of DFuns is can cause a huge+and entirely unnecessary blowup in program size. Consider a call to+ f @[[[[[[[[T]]]]]]]] d1 x+where df :: C a => C [a]+ d1 :: C [[[[[[[[T]]]]]]]] = dfC[] @[[[[[[[T]]]]]]] d1+ d2 :: C [[[[[[[T]]]]]]] = dfC[] @[[[[[[T]]]]]] d3+ ...+Now we'll specialise f's RHS, which may give rise to calls to 'g',+also overloaded, which we will specialise, and so on. However, if+we specialise the calls to dfC[], we'll generate specialised copies of+all methods of C, at all types; and the same for C's superclasses.++And many of these specialised functions will never be called. We are+going to call the specialised 'f', and the specialised 'g', but DFuns+group functions into a tuple, many of whose elements may never be used.++With deeply-nested types this can lead to a simply overwhelming number+of specialisations: see #18223 for a simple example (from the wild).+I measured the number of specialisations for various numbers of calls+of `flip evalStateT ()`, and got this++ Size after one simplification+ #calls #SPEC rules Terms Types+ 5 56 3100 10600+ 9 108 13660 77206++The real tests case has 60+ calls, which blew GHC out of the water.++Solution: don't specialise DFuns. The downside is that if we end+up with (h (dfun d)), /and/ we don't specialise 'h', then we won't+pass to 'h' a tuple of specialised functions.++However, the flag -fspecialise-aggressively (experimental, off by default)+allows DFuns to specialise as well.++Note [Avoiding loops in specImports]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We must take great care when specialising instance declarations (functions like $fOrdList) lest we accidentally build a recursive dictionary. See Note [Avoiding loops].@@ -1001,6 +1037,9 @@ -- Dict Ids that we know something about -- and hence may be worth specialising against -- See Note [Interesting dictionary arguments]++ , se_module :: Module+ , se_dflags :: DynFlags } instance Outputable SpecEnv where@@ -1308,7 +1347,7 @@ specDefn env body_uds fn rhs = do { let (body_uds_without_me, calls_for_me) = callsForMe fn body_uds rules_for_me = idCoreRules fn- ; (rules, spec_defns, spec_uds) <- specCalls Nothing env rules_for_me+ ; (rules, spec_defns, spec_uds) <- specCalls False env rules_for_me calls_for_me fn rhs ; return ( fn `addIdSpecialisations` rules , spec_defns@@ -1321,8 +1360,8 @@ -- body_uds_without_me ----------------------------specCalls :: Maybe Module -- Just this_mod => specialising imported fn- -- Nothing => specialising local fn+specCalls :: Bool -- True => specialising imported fn+ -- False => specialising local fn -> SpecEnv -> [CoreRule] -- Existing RULES for the fn -> [CallInfo]@@ -1337,7 +1376,7 @@ , [(Id,CoreExpr)] -- Specialised definition , UsageDetails ) -- Usage details from specialised RHSs -specCalls mb_mod env existing_rules calls_for_me fn rhs+specCalls spec_imp env existing_rules calls_for_me fn rhs -- The first case is the interesting one | notNull calls_for_me -- And there are some calls to specialise && not (isNeverActive (idInlineActivation fn))@@ -1368,7 +1407,9 @@ inl_act = inlinePragmaActivation inl_prag is_local = isLocalId fn is_dfun = isDFunId fn-+ dflags = se_dflags env+ ropts = initRuleOpts dflags+ this_mod = se_module env -- Figure out whether the function has an INLINE pragma -- See Note [Inline specialisations] @@ -1410,8 +1451,6 @@ -- , ppr dx_binds ]) $ -- return () - ; dflags <- getDynFlags- ; let ropts = initRuleOpts dflags ; if not useful -- No useful specialisation || already_covered ropts rules_acc rule_lhs_args then return spec_acc@@ -1439,17 +1478,15 @@ = Nothing ; spec_fn <- newSpecIdSM fn spec_fn_ty spec_join_arity- ; this_mod <- getModule ; let -- The rule to put in the function's specialisation is: -- forall x @b d1' d2'. -- f x @T1 @b @T2 d1' d2' = f1 x @b -- See Note [Specialising Calls]- herald = case mb_mod of- Nothing -- Specialising local fn- -> text "SPEC"- Just this_mod -- Specialising imported fn- -> text "SPEC/" <> ppr this_mod+ herald | spec_imp = -- Specialising imported fn+ text "SPEC/" <> ppr this_mod+ | otherwise = -- Specialising local fn+ text "SPEC" rule_name = mkFastString $ showSDoc dflags $ herald <+> ftext (occNameFS (getOccName fn))@@ -1478,6 +1515,8 @@ -- See Note [Specialising Calls] spec_uds = foldr consDictBind rhs_uds dx_binds + simpl_opts = initSimpleOpts dflags+ -------------------------------------- -- Add a suitable unfolding if the spec_inl_prag says so -- See Note [Inline specialisations]@@ -1490,7 +1529,7 @@ = (inl_prag { inl_inline = NoUserInline }, noUnfolding) | otherwise- = (inl_prag, specUnfolding dflags spec_bndrs (`mkApps` spec_args)+ = (inl_prag, specUnfolding simpl_opts spec_bndrs (`mkApps` spec_args) rule_lhs_args fn_unf) --------------------------------------@@ -2476,15 +2515,15 @@ res = mkCallUDs' env f args mkCallUDs' env f args- | not (want_calls_for f) -- Imported from elsewhere- || null ci_key -- No useful specialisation- -- See also Note [Specialisations already covered]+ | wantCallsFor env f -- We want it, and...+ , not (null ci_key) -- this call site has a useful specialisation+ = -- pprTrace "mkCallUDs: keeping" _trace_doc+ singleCall f ci_key++ | otherwise -- See also Note [Specialisations already covered] = -- pprTrace "mkCallUDs: discarding" _trace_doc emptyUDs - | otherwise- = -- pprTrace "mkCallUDs: keeping" _trace_doc- singleCall f ci_key where _trace_doc = vcat [ppr f, ppr args, ppr ci_key] pis = fst $ splitPiTys $ idType f@@ -2510,56 +2549,47 @@ -- we decide on a case by case basis if we want to specialise -- on this argument; if so, SpecDict, if not UnspecArg mk_spec_arg arg (Anon InvisArg pred)- | type_determines_value (scaledThing pred)- , interestingDict env arg -- Note [Interesting dictionary arguments]+ | not (isIPLikePred (scaledThing pred))+ -- See Note [Type determines value]+ , interestingDict env arg+ -- See Note [Interesting dictionary arguments] = SpecDict arg+ | otherwise = UnspecArg mk_spec_arg _ (Anon VisArg _) = UnspecArg - want_calls_for f = isLocalId f || isJust (maybeUnfoldingTemplate (realIdUnfolding f))- -- For imported things, we gather call instances if- -- there is an unfolding that we could in principle specialise- -- We might still decide not to use it (consulting dflags)- -- in specImports- -- Use 'realIdUnfolding' to ignore the loop-breaker flag!-- type_determines_value pred -- See Note [Type determines value]- = case classifyPredType pred of- ClassPred cls _ -> not (isIPClass cls) -- Superclasses can't be IPs- EqPred {} -> True- IrredPred {} -> True -- Things like (D []) where D is a- -- Constraint-ranged family; #7785- ForAllPred {} -> True+wantCallsFor :: SpecEnv -> Id -> Bool+wantCallsFor _env _f = True+ -- We could reduce the size of the UsageDetails by being less eager+ -- about collecting calls for LocalIds: there is no point for+ -- ones that are lambda-bound. We can't decide this by looking at+ -- the (absence of an) unfolding, because unfoldings for local+ -- functions are discarded by cloneBindSM, so no local binder will+ -- have an unfolding at this stage. We'd have to keep a candidate+ -- set of let-binders.+ --+ -- Not many lambda-bound variables have dictionary arguments, so+ -- this would make little difference anyway.+ --+ -- For imported Ids we could check for an unfolding, but we have to+ -- do so anyway in canSpecImport, and it seems better to have it+ -- all in one place. So we simply collect usage info for imported+ -- overloaded functions. -{--Note [Type determines value]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Only specialise on non-IP *class* params, because these are the ones-whose *type* determines their *value*. In particular, with implicit-params, the type args *don't* say what the value of the implicit param-is! See #7101.+{- Note [Type determines value]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Only specialise on non-impicit-parameter predicates, because these+are the ones whose *type* determines their *value*. In particular,+with implicit params, the type args *don't* say what the value of the+implicit param is! See #7101. So we treat implicit params just like ordinary arguments for the purposes of specialisation. Note that we still want to specialise functions with implicit params if they have *other* dicts which are class params; see #17930. -One apparent additional complexity involves type families. For-example, consider- type family D (v::*->*) :: Constraint- type instance D [] = ()- f :: D v => v Char -> Int-If we see a call (f "foo"), we'll pass a "dictionary"- () |> (g :: () ~ D [])-and it's good to specialise f at this dictionary.--So the question is: can an implicit parameter "hide inside" a-type-family constraint like (D a). Well, no. We don't allow- type instance D Maybe = ?x:Int-Hence the IrredPred case in type_determines_value. See #7785.- Note [Interesting dictionary arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this@@ -2796,55 +2826,12 @@ ************************************************************************ -} -newtype SpecM a = SpecM (State SpecState a) deriving (Functor)--data SpecState = SpecState {- spec_uniq_supply :: UniqSupply,- spec_module :: Module,- spec_dflags :: DynFlags- }--instance Applicative SpecM where- pure x = SpecM $ return x- (<*>) = ap--instance Monad SpecM where- SpecM x >>= f = SpecM $ do y <- x- case f y of- SpecM z ->- z--instance MonadFail SpecM where- fail str = SpecM $ error str--instance MonadUnique SpecM where- getUniqueSupplyM- = SpecM $ do st <- get- let (us1, us2) = splitUniqSupply $ spec_uniq_supply st- put $ st { spec_uniq_supply = us2 }- return us1-- getUniqueM- = SpecM $ do st <- get- let (u,us') = takeUniqFromSupply $ spec_uniq_supply st- put $ st { spec_uniq_supply = us' }- return u--instance HasDynFlags SpecM where- getDynFlags = SpecM $ liftM spec_dflags get--instance HasModule SpecM where- getModule = SpecM $ liftM spec_module get+type SpecM a = UniqSM a -runSpecM :: DynFlags -> Module -> SpecM a -> CoreM a-runSpecM dflags this_mod (SpecM spec)- = do us <- getUniqueSupplyM- let initialState = SpecState {- spec_uniq_supply = us,- spec_module = this_mod,- spec_dflags = dflags- }- return $ evalState spec initialState+runSpecM :: SpecM a -> CoreM a+runSpecM thing_inside+ = do { us <- getUniqueSupplyM+ ; return (initUs_ us thing_inside) } mapAndCombineSM :: (a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails) mapAndCombineSM _ [] = return ([], emptyUDs)
compiler/GHC/Core/Opt/WorkWrap.hs view
@@ -11,7 +11,8 @@ import GHC.Core.Opt.Arity ( manifestArity ) import GHC.Core-import GHC.Core.Unfold ( certainlyWillInline, mkWwInlineRule, mkWorkerUnfolding )+import GHC.Core.Unfold+import GHC.Core.Unfold.Make import GHC.Core.Utils ( exprType, exprIsHNF ) import GHC.Core.FVs ( exprFreeVars ) import GHC.Types.Var@@ -22,6 +23,7 @@ import GHC.Types.Basic import GHC.Driver.Session import GHC.Driver.Ppr+import GHC.Driver.Config import GHC.Types.Demand import GHC.Types.Cpr import GHC.Core.Opt.WorkWrap.Utils@@ -467,7 +469,7 @@ tryWW dflags fam_envs is_rec fn_id rhs -- See Note [Worker-wrapper for NOINLINE functions] - | Just stable_unf <- certainlyWillInline dflags fn_info+ | Just stable_unf <- certainlyWillInline uf_opts fn_info = return [ (fn_id `setIdUnfolding` stable_unf, rhs) ] -- See Note [Don't w/w INLINE things] -- See Note [Don't w/w inline small non-loop-breaker things]@@ -482,6 +484,7 @@ = return [ (new_fn_id, rhs) ] where+ uf_opts = unfoldingOpts dflags fn_info = idInfo fn_id (wrap_dmds, div) = splitStrictSig (strictnessInfo fn_info) @@ -602,6 +605,8 @@ -- worker is join point iff wrapper is join point -- (see Note [Don't w/w join points for CPR]) + simpl_opts = initSimpleOpts dflags+ work_id = mkWorkerId work_uniq fn_id (exprType work_rhs) `setIdOccInfo` occInfo fn_info -- Copy over occurrence info from parent@@ -611,7 +616,7 @@ `setInlinePragma` work_prag - `setIdUnfolding` mkWorkerUnfolding dflags work_fn fn_unfolding+ `setIdUnfolding` mkWorkerUnfolding simpl_opts work_fn fn_unfolding -- See Note [Worker-wrapper for INLINABLE functions] `setIdStrictness` mkClosedStrictSig work_demands div@@ -637,7 +642,7 @@ wrap_rhs = wrap_fn work_id wrap_prag = mkStrWrapperInlinePrag fn_inl_prag- wrap_id = fn_id `setIdUnfolding` mkWwInlineRule dflags wrap_rhs arity+ wrap_id = fn_id `setIdUnfolding` mkWwInlineRule simpl_opts wrap_rhs arity `setInlinePragma` wrap_prag `setIdOccInfo` noOccInfo -- Zap any loop-breaker-ness, to avoid bleating from Lint
compiler/GHC/Core/Rules.hs view
@@ -67,9 +67,9 @@ import GHC.Data.FastString import GHC.Data.Maybe import GHC.Data.Bag-import GHC.Utils.Misc+import GHC.Utils.Misc as Utils import Data.List-import Data.Ord+import Data.Function ( on ) import Control.Monad ( guard ) {-@@ -271,7 +271,7 @@ pprRulesForUser rules = withPprStyle defaultUserStyle $ pprRules $- sortBy (comparing ruleName) $+ sortBy (lexicalCompareFS `on` ruleName) $ tidyRules emptyTidyEnv rules {-@@ -358,7 +358,7 @@ extendRuleBase :: RuleBase -> CoreRule -> RuleBase extendRuleBase rule_base rule- = extendNameEnv_Acc (:) singleton rule_base (ruleIdName rule) rule+ = extendNameEnv_Acc (:) Utils.singleton rule_base (ruleIdName rule) rule pprRuleBase :: RuleBase -> SDoc pprRuleBase rules = pprUFM rules $ \rss ->
compiler/GHC/CoreToByteCode.hs view
@@ -648,7 +648,7 @@ -- handle pairs with one void argument (e.g. state token) schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)])- | isUnboxedTupleCon dc+ | isUnboxedTupleDataCon dc -- Convert -- case .... of x { (# V'd-thing, a #) -> ... } -- to@@ -667,7 +667,7 @@ -- handle unit tuples schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)])- | isUnboxedTupleCon dc+ | isUnboxedTupleDataCon dc , typePrimRep (idType bndr) `lengthAtMost` 1 = doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr) @@ -825,7 +825,7 @@ -- Case 2: Constructor application | Just con <- maybe_saturated_dcon- , isUnboxedTupleCon con+ , isUnboxedTupleDataCon con = case args_r_to_l of [arg1,arg2] | isVAtom arg1 -> unboxedTupleReturn d s p arg2@@ -1090,7 +1090,7 @@ my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-} my_discr (DataAlt dc, _, _)- | isUnboxedTupleCon dc || isUnboxedSumCon dc+ | isUnboxedTupleDataCon dc || isUnboxedSumDataCon dc = multiValException | otherwise = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))
compiler/GHC/CoreToStg.hs view
@@ -699,7 +699,7 @@ , -- Dynamic StgConApps are updatable not (isDllConApp dflags this_mod con args) = -- CorePrep does this right, but just to make sure- ASSERT2( not (isUnboxedTupleCon con || isUnboxedSumCon con)+ ASSERT2( not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con) , ppr bndr $$ ppr con $$ ppr args) ( StgRhsCon dontCareCCS con args, ccs )
compiler/GHC/Driver/Backpack.hs view
@@ -27,12 +27,14 @@ import GHC hiding (Failed, Succeeded) import GHC.Parser import GHC.Parser.Lexer+import GHC.Driver.Config import GHC.Driver.Monad import GHC.Driver.Session import GHC.Driver.Ppr import GHC.Tc.Utils.Monad import GHC.Tc.Module import GHC.Unit+import GHC.Unit.State import GHC.Driver.Types import GHC.Data.StringBuffer import GHC.Data.FastString@@ -82,7 +84,7 @@ buf <- liftIO $ hGetStringBuffer src_filename let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great- case unP parseBackpack (mkPState dflags buf loc) of+ case unP parseBackpack (initParserState (initParserOpts dflags) buf loc) of PFailed pst -> throwErrors (getErrorMessages pst dflags) POk _ pkgname_bkp -> do -- OK, so we have an LHsUnit PackageName, but we want an@@ -560,7 +562,7 @@ -- ---------------------------------------------------------------------------- -- Conversion from PackageName to HsComponentId -type PackageNameMap a = Map PackageName a+type PackageNameMap a = UniqFM PackageName a -- For now, something really simple, since we're not actually going -- to use this for anything@@ -569,7 +571,7 @@ = (pn, HsComponentId pn (Indefinite (UnitId fs))) bkpPackageNameMap :: [LHsUnit PackageName] -> PackageNameMap HsComponentId-bkpPackageNameMap units = Map.fromList (map unitDefines units)+bkpPackageNameMap units = listToUFM (map unitDefines units) renameHsUnits :: UnitState -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId] renameHsUnits pkgstate m units = map (fmap renameHsUnit) units@@ -577,7 +579,7 @@ renamePackageName :: PackageName -> HsComponentId renamePackageName pn =- case Map.lookup pn m of+ case lookupUFM m pn of Nothing -> case lookupPackageName pkgstate pn of Nothing -> error "no package name"
compiler/GHC/Driver/CodeOutput.hs view
@@ -16,6 +16,7 @@ #include "GhclibHsVersions.h" import GHC.Prelude+import GHC.Platform import GHC.CmmToAsm ( nativeCodeGen ) import GHC.CmmToLlvm ( llvmCodeGen )@@ -39,6 +40,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Unit+import GHC.Unit.State import GHC.Types.SrcLoc import GHC.Types.CostCentre @@ -83,7 +85,7 @@ dflags (text "CmmLint"<+>brackets (ppr this_mod)) (const ()) $ do- { case cmmLint dflags cmm of+ { case cmmLint (targetPlatform dflags) cmm of Just err -> do { log_action dflags dflags NoReason@@ -259,8 +261,8 @@ -- module; -- | Generate code to initialise cost centres-profilingInitCode :: Module -> CollectedCCs -> SDoc-profilingInitCode this_mod (local_CCs, singleton_CCSs)+profilingInitCode :: Platform -> Module -> CollectedCCs -> SDoc+profilingInitCode platform this_mod (local_CCs, singleton_CCSs) = vcat $ map emit_cc_decl local_CCs ++ map emit_ccs_decl singleton_CCSs@@ -277,22 +279,22 @@ where emit_cc_decl cc = text "extern CostCentre" <+> cc_lbl <> text "[];"- where cc_lbl = ppr (mkCCLabel cc)+ where cc_lbl = pdoc platform (mkCCLabel cc) local_cc_list_label = text "local_cc_" <> ppr this_mod emit_cc_list ccs = text "static CostCentre *" <> local_cc_list_label <> text "[] ="- <+> braces (vcat $ [ ppr (mkCCLabel cc) <> comma+ <+> braces (vcat $ [ pdoc platform (mkCCLabel cc) <> comma | cc <- ccs ] ++ [text "NULL"]) <> semi emit_ccs_decl ccs = text "extern CostCentreStack" <+> ccs_lbl <> text "[];"- where ccs_lbl = ppr (mkCCSLabel ccs)+ where ccs_lbl = pdoc platform (mkCCSLabel ccs) singleton_cc_list_label = text "singleton_cc_" <> ppr this_mod emit_ccs_list ccs = text "static CostCentreStack *" <> singleton_cc_list_label <> text "[] ="- <+> braces (vcat $ [ ppr (mkCCSLabel cc) <> comma+ <+> braces (vcat $ [ pdoc platform (mkCCSLabel cc) <> comma | cc <- ccs ] ++ [text "NULL"]) <> semi
compiler/GHC/Driver/Finder.hs view
@@ -37,6 +37,7 @@ import GHC.Prelude import GHC.Unit+import GHC.Unit.State import GHC.Driver.Types import GHC.Data.FastString import GHC.Utils.Misc
compiler/GHC/Driver/Main.hs view
@@ -102,6 +102,7 @@ import GHC.Parser.Annotation import GHC.Unit+import GHC.Unit.State import GHC.Types.Name.Reader import GHC.Hs import GHC.Hs.Dump@@ -137,6 +138,7 @@ import GHC.Cmm.Pipeline import GHC.Cmm.Info import GHC.Driver.CodeOutput+import GHC.Driver.Config import GHC.Core.InstEnv import GHC.Core.FamInstEnv import GHC.Utils.Fingerprint ( Fingerprint )@@ -352,7 +354,7 @@ = parseSignature | otherwise = parseModule - case unP parseMod (mkPState dflags buf loc) of+ case unP parseMod (initParserState (initParserOpts dflags) buf loc) of PFailed pst -> handleWarningsThrowErrors (getMessages pst dflags) POk pst rdr_module -> do@@ -1416,10 +1418,10 @@ <- {-# SCC "CoreToStg" #-} myCoreToStg dflags this_mod prepd_binds - let cost_centre_info =- (S.toList local_ccs ++ caf_ccs, caf_cc_stacks)+ let cost_centre_info = (S.toList local_ccs ++ caf_ccs, caf_cc_stacks)+ platform = targetPlatform dflags prof_init- | sccProfilingEnabled dflags = profilingInitCode this_mod cost_centre_info+ | sccProfilingEnabled dflags = profilingInitCode platform this_mod cost_centre_info | otherwise = empty foreign_stubs = foreign_stubs0 `appendStubC` prof_init @@ -1445,7 +1447,7 @@ let dump a = do unless (null a) $- dumpIfSet_dyn dflags Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (ppr a)+ dumpIfSet_dyn dflags Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (pdoc platform a) return a rawcmms1 = Stream.mapM dump rawcmms0 @@ -1493,9 +1495,10 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do let dflags = hsc_dflags hsc_env home_unit = mkHomeUnitFromFlags dflags+ platform = targetPlatform dflags cmm <- ioMsgMaybe $ parseCmmFile dflags filename liftIO $ do- dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (ppr cmm)+ dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm) let -- Make up a module name to give the NCG. We can't pass bottom here -- lest we reproduce #11784. mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename@@ -1512,7 +1515,7 @@ unless (null cmmgroup) $ dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm"- FormatCMM (ppr cmmgroup)+ FormatCMM (pdoc platform cmmgroup) rawCmms <- lookupHook (\x -> cmmToRawCmmHook x) (\dflgs _ -> cmmToRawCmm dflgs) dflags dflags Nothing (Stream.yield cmmgroup) _ <- codeOutput dflags cmm_mod output_filename no_loc NoStubs [] []@@ -1555,6 +1558,7 @@ doCodeGen hsc_env this_mod data_tycons cost_centre_info stg_binds hpc_info = do let dflags = hsc_dflags hsc_env+ platform = targetPlatform dflags let stg_binds_w_fvs = annTopBindingsFreeVars stg_binds @@ -1574,7 +1578,7 @@ let dump1 a = do unless (null a) $ dumpIfSet_dyn dflags Opt_D_dump_cmm_from_stg- "Cmm produced by codegen" FormatCMM (ppr a)+ "Cmm produced by codegen" FormatCMM (pdoc platform a) return a ppr_stream1 = Stream.mapM dump1 cmm_stream@@ -1590,7 +1594,7 @@ dump2 a = do unless (null a) $- dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" FormatCMM (ppr a)+ dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform a) return a return (Stream.mapM dump2 pipeline_stream)@@ -1872,7 +1876,7 @@ let buf = stringToStringBuffer str loc = mkRealSrcLoc (fsLit source) linenumber 1 - case unP parser (mkPState dflags buf loc) of+ case unP parser (initParserState (initParserOpts dflags) buf loc) of PFailed pst -> do handleWarningsThrowErrors (getMessages pst dflags)
compiler/GHC/Driver/Make.hs view
@@ -47,6 +47,7 @@ import GHC.Parser.Header import GHC.Driver.Types import GHC.Unit+import GHC.Unit.State import GHC.IfaceToCore ( typecheckIface ) import GHC.Tc.Utils.Monad ( initIfaceCheck ) import GHC.Driver.Main@@ -1373,7 +1374,8 @@ -- -- There better had not be any cyclic groups here -- we check for them. upsweep- :: GhcMonad m+ :: forall m+ . GhcMonad m => Maybe Messager -> HomePackageTable -- ^ HPT from last time round (pruned) -> StableModules -- ^ stable modules (see checkStability)@@ -1415,8 +1417,7 @@ return (Failed, done') upsweep'- :: GhcMonad m- => HomePackageTable+ :: HomePackageTable -> ModuleGraph -> [SCC ModSummary] -> Int
compiler/GHC/Driver/Pipeline.hs view
@@ -41,6 +41,7 @@ import GHC.Driver.Pipeline.Monad import GHC.Unit+import GHC.Unit.State import GHC.Platform.Ways import GHC.Platform.ArchOS import GHC.Parser.Header@@ -394,7 +395,56 @@ -- --------------------------------------------------------------------------- -- Link-+--+-- Note [Dynamic linking on macOS]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Since macOS Sierra (10.14), the dynamic system linker enforces+-- a limit on the Load Commands. Specifically the Load Command Size+-- Limit is at 32K (32768). The Load Commands contain the install+-- name, dependencies, runpaths, and a few other commands. We however+-- only have control over the install name, dependencies and runpaths.+--+-- The install name is the name by which this library will be+-- referenced. This is such that we do not need to bake in the full+-- absolute location of the library, and can move the library around.+--+-- The dependency commands contain the install names from of referenced+-- libraries. Thus if a libraries install name is @rpath/libHS...dylib,+-- that will end up as the dependency.+--+-- Finally we have the runpaths, which informs the linker about the+-- directories to search for the referenced dependencies.+--+-- The system linker can do recursive linking, however using only the+-- direct dependencies conflicts with ghc's ability to inline across+-- packages, and as such would end up with unresolved symbols.+--+-- Thus we will pass the full dependency closure to the linker, and then+-- ask the linker to remove any unused dynamic libraries (-dead_strip_dylibs).+--+-- We still need to add the relevant runpaths, for the dynamic linker to+-- lookup the referenced libraries though. The linker (ld64) does not+-- have any option to dead strip runpaths; which makes sense as runpaths+-- can be used for dependencies of dependencies as well.+--+-- The solution we then take in GHC is to not pass any runpaths to the+-- linker at link time, but inject them after the linking. For this to+-- work we'll need to ask the linker to create enough space in the header+-- to add more runpaths after the linking (-headerpad 8000).+--+-- After the library has been linked by $LD (usually ld64), we will use+-- otool to inspect the libraries left over after dead stripping, compute+-- the relevant runpaths, and inject them into the linked product using+-- the install_name_tool command.+--+-- This strategy should produce the smallest possible set of load commands+-- while still retaining some form of relocatability via runpaths.+--+-- The only way I can see to reduce the load command size further would be+-- by shortening the library names, or start putting libraries into the same+-- folders, such that one runpath would be sufficient for multiple/all+-- libraries. link :: GhcLink -- interactive or batch -> DynFlags -- dynamic flags -> Bool -- attempt linking in batch mode?@@ -1188,8 +1238,11 @@ hscGenHardCode hsc_env' cgguts mod_location output_fn final_iface <- liftIO (mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface (Just cg_infos))- let final_mod_details = {-# SCC updateModDetailsIdInfos #-}- updateModDetailsIdInfos iface_dflags cg_infos mod_details+ let final_mod_details+ | gopt Opt_OmitInterfacePragmas iface_dflags+ = mod_details+ | otherwise = {-# SCC updateModDetailsIdInfos #-}+ updateModDetailsIdInfos cg_infos mod_details setIface final_iface final_mod_details -- See Note [Writing interface files]@@ -1787,9 +1840,12 @@ rc_objs <- maybeCreateManifest dflags output_fn - let link = if staticLink- then GHC.SysTools.runLibtool- else GHC.SysTools.runLink+ let link dflags args | staticLink = GHC.SysTools.runLibtool dflags args+ | platformOS platform == OSDarwin+ = GHC.SysTools.runLink dflags args >> GHC.SysTools.runInjectRPaths dflags pkg_lib_paths output_fn+ | otherwise+ = GHC.SysTools.runLink dflags args+ link dflags ( map GHC.SysTools.Option verbFlags ++ [ GHC.SysTools.Option "-o"@@ -1856,7 +1912,13 @@ ++ pkg_link_opts ++ pkg_framework_opts ++ (if platformOS platform == OSDarwin- then [ "-Wl,-dead_strip_dylibs" ]+ -- dead_strip_dylibs, will remove unused dylibs, and thus save+ -- space in the load commands. The -headerpad is necessary so+ -- that we can inject more @rpath's later for the left over+ -- libraries during runInjectRpaths phase.+ --+ -- See Note [Dynamic linking on macOS].+ then [ "-Wl,-dead_strip_dylibs", "-Wl,-headerpad,8000" ] else []) ))
compiler/GHC/HsToCore.hs view
@@ -22,6 +22,7 @@ import GHC.HsToCore.Usage import GHC.Driver.Session+import GHC.Driver.Config import GHC.Driver.Types import GHC.Driver.Backend import GHC.Hs@@ -38,7 +39,7 @@ import GHC.Core.FVs ( exprsSomeFreeVarsList ) import GHC.Core.SimpleOpt ( simpleOptPgm, simpleOptExpr ) import GHC.Core.Utils-import GHC.Core.Unfold+import GHC.Core.Unfold.Make import GHC.Core.Ppr import GHC.HsToCore.Monad import GHC.HsToCore.Expr@@ -170,10 +171,13 @@ -- things into the in-scope set before simplifying; so we get no unfolding for F#! ; endPassIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps- ; (ds_binds, ds_rules_for_imps)- <- simpleOptPgm dflags mod final_pgm rules_for_imps+ ; let simpl_opts = initSimpleOpts dflags+ ; let (ds_binds, ds_rules_for_imps, occ_anald_binds)+ = simpleOptPgm simpl_opts mod final_pgm rules_for_imps -- The simpleOptPgm gets rid of type -- bindings plus any stupid dead code+ ; dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"+ FormatCore (pprCoreBindings occ_anald_binds $$ pprRules ds_rules_for_imps ) ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps @@ -224,7 +228,7 @@ mg_modBreaks = modBreaks, mg_safe_haskell = safe_mode, mg_trust_pkg = imp_trust_own_pkg imports,- mg_complete_sigs = complete_matches,+ mg_complete_matches = complete_matches, mg_doc_hdr = doc_hdr, mg_decl_docs = decl_docs, mg_arg_docs = arg_docs@@ -409,7 +413,8 @@ -- we don't want to attach rules to the bindings of implicit Ids, -- because they don't show up in the bindings until just before code gen fn_name = idName fn_id- final_rhs = simpleOptExpr dflags rhs'' -- De-crap it+ simpl_opts = initSimpleOpts dflags+ final_rhs = simpleOptExpr simpl_opts rhs'' -- De-crap it rule_name = snd (unLoc name) final_bndrs_set = mkVarSet final_bndrs arg_ids = filterOut (`elemVarSet` final_bndrs_set) $@@ -738,7 +743,7 @@ info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma- `setUnfoldingInfo` mkCompulsoryUnfolding rhs+ `setUnfoldingInfo` mkCompulsoryUnfolding' rhs ty = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar , openAlphaTyVar, openBetaTyVar ] $
compiler/GHC/HsToCore/Binds.hs view
@@ -33,7 +33,7 @@ import GHC.HsToCore.Monad import GHC.HsToCore.GuardedRHSs import GHC.HsToCore.Utils-import GHC.HsToCore.PmCheck ( addTyCsDs, checkGRHSs )+import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs ) import GHC.Hs -- lots of things import GHC.Core -- lots of things@@ -42,7 +42,7 @@ import GHC.Core.Make import GHC.Core.Utils import GHC.Core.Opt.Arity ( etaExpand )-import GHC.Core.Unfold+import GHC.Core.Unfold.Make import GHC.Core.FVs import GHC.Data.Graph.Directed import GHC.Core.Predicate@@ -72,6 +72,7 @@ import GHC.Types.Basic import GHC.Driver.Session import GHC.Driver.Ppr+import GHC.Driver.Config import GHC.Data.FastString import GHC.Utils.Misc import GHC.Types.Unique.Set( nonDetEltsUniqSet )@@ -151,14 +152,14 @@ , fun_matches = matches , fun_ext = co_fn , fun_tick = tick })- = do { (args, body) <- addTyCsDs FromSource (hsWrapDictBinders co_fn) $+ = do { (args, body) <- addTyCs FromSource (hsWrapDictBinders co_fn) $ -- FromSource might not be accurate (we don't have any -- origin annotations for things in this module), but at -- worst we do superfluous calls to the pattern match -- oracle.- -- addTyCsDs: Add type evidence to the refinement type+ -- addTyCs: Add type evidence to the refinement type -- predicate of the coverage checker- -- See Note [Type and Term Equality Propagation] in "GHC.HsToCore.PmCheck"+ -- See Note [Long-distance information] in "GHC.HsToCore.Pmc" matchWrapper (mkPrefixFunRhs (L loc (idName fun))) Nothing matches@@ -184,8 +185,8 @@ dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss , pat_ext = ty , pat_ticks = (rhs_tick, var_ticks) })- = do { rhss_deltas <- checkGRHSs PatBindGuards grhss- ; body_expr <- dsGuarded grhss ty rhss_deltas+ = do { rhss_nablas <- pmcGRHSs PatBindGuards grhss+ ; body_expr <- dsGuarded grhss ty rhss_nablas ; let body' = mkOptTickBox rhs_tick body_expr pat' = decideBangHood dflags pat ; (force_var,sel_binds) <- mkSelectorBinds var_ticks pat body'@@ -200,11 +201,11 @@ , abs_exports = exports , abs_ev_binds = ev_binds , abs_binds = binds, abs_sig = has_sig })- = do { ds_binds <- addTyCsDs FromSource (listToBag dicts) $+ = do { ds_binds <- addTyCs FromSource (listToBag dicts) $ dsLHsBinds binds- -- addTyCsDs: push type constraints deeper+ -- addTyCs: push type constraints deeper -- for inner pattern match check- -- See Check, Note [Type and Term Equality Propagation]+ -- See Check, Note [Long-distance information] ; ds_ev_binds <- dsTcEvBinds_s ev_binds @@ -380,7 +381,7 @@ makeCorePair dflags gbl_id is_default_method dict_arity rhs | is_default_method -- Default methods are *always* inlined -- See Note [INLINE and default methods] in GHC.Tc.TyCl.Instance- = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)+ = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding simpl_opts rhs, rhs) | otherwise = case inlinePragmaSpec inline_prag of@@ -390,20 +391,21 @@ Inline -> inline_pair where+ simpl_opts = initSimpleOpts dflags inline_prag = idInlinePragma gbl_id- inlinable_unf = mkInlinableUnfolding dflags rhs+ inlinable_unf = mkInlinableUnfolding simpl_opts rhs inline_pair | Just arity <- inlinePragmaSat inline_prag -- Add an Unfolding for an INLINE (but not for NOINLINE) -- And eta-expand the RHS; see Note [Eta-expanding INLINE things] , let real_arity = dict_arity + arity -- NB: The arity in the InlineRule takes account of the dictionaries- = ( gbl_id `setIdUnfolding` mkInlineUnfoldingWithArity real_arity rhs+ = ( gbl_id `setIdUnfolding` mkInlineUnfoldingWithArity real_arity simpl_opts rhs , etaExpand real_arity rhs) | otherwise = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $- (gbl_id `setIdUnfolding` mkInlineUnfolding rhs, rhs)+ (gbl_id `setIdUnfolding` mkInlineUnfolding simpl_opts rhs, rhs) dictArity :: [Var] -> Arity -- Don't count coercion variables in arity@@ -704,8 +706,9 @@ { this_mod <- getModule ; let fn_unf = realIdUnfolding poly_id- spec_unf = specUnfolding dflags spec_bndrs core_app rule_lhs_args fn_unf- spec_id = mkLocalId spec_name Many spec_ty -- Specialised binding is toplevel, hence Many.+ simpl_opts = initSimpleOpts dflags+ spec_unf = specUnfolding simpl_opts spec_bndrs core_app rule_lhs_args fn_unf+ spec_id = mkLocalId spec_name Many spec_ty -- Specialised binding is toplevel, hence Many. `setInlinePragma` inl_prag `setIdUnfolding` spec_unf @@ -863,8 +866,9 @@ | otherwise = Left bad_shape_msg where+ simpl_opts = initSimpleOpts dflags lhs1 = drop_dicts orig_lhs- lhs2 = simpleOptExpr dflags lhs1 -- See Note [Simplify rule LHS]+ lhs2 = simpleOptExpr simpl_opts lhs1 -- See Note [Simplify rule LHS] (fun2,args2) = collectArgs lhs2 lhs_fvs = exprFreeVars lhs2
compiler/GHC/HsToCore/Coverage.hs view
@@ -505,23 +505,25 @@ -- in the addTickLHsExpr family of functions.) addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc)-addTickHsExpr e@(HsVar _ (L _ id)) = do freeVar id; return e-addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar"+addTickHsExpr e@(HsVar _ (L _ id)) = do freeVar id; return e+addTickHsExpr e@(HsUnboundVar id _) = do freeVar id; return e+addTickHsExpr e@(HsRecFld _ (Ambiguous id _)) = do freeVar id; return e+addTickHsExpr e@(HsRecFld _ (Unambiguous id _)) = do freeVar id; return e addTickHsExpr e@(HsConLikeOut _ con) | Just id <- conLikeWrapId_maybe con = do freeVar id; return e-addTickHsExpr e@(HsIPVar {}) = return e-addTickHsExpr e@(HsOverLit {}) = return e-addTickHsExpr e@(HsOverLabel{}) = return e-addTickHsExpr e@(HsLit {}) = return e-addTickHsExpr (HsLam x matchgroup) = liftM (HsLam x)- (addTickMatchGroup True matchgroup)-addTickHsExpr (HsLamCase x mgs) = liftM (HsLamCase x)- (addTickMatchGroup True mgs)-addTickHsExpr (HsApp x e1 e2) = liftM2 (HsApp x) (addTickLHsExprNever e1)- (addTickLHsExpr e2)-addTickHsExpr (HsAppType x e ty) = liftM3 HsAppType (return x)- (addTickLHsExprNever e)- (return ty)+addTickHsExpr e@(HsIPVar {}) = return e+addTickHsExpr e@(HsOverLit {}) = return e+addTickHsExpr e@(HsOverLabel{}) = return e+addTickHsExpr e@(HsLit {}) = return e+addTickHsExpr (HsLam x mg) = liftM (HsLam x)+ (addTickMatchGroup True mg)+addTickHsExpr (HsLamCase x mgs) = liftM (HsLamCase x)+ (addTickMatchGroup True mgs)+addTickHsExpr (HsApp x e1 e2) = liftM2 (HsApp x) (addTickLHsExprNever e1)+ (addTickLHsExpr e2)+addTickHsExpr (HsAppType x e ty) = liftM3 HsAppType (return x)+ (addTickLHsExprNever e)+ (return ty) addTickHsExpr (OpApp fix e1 e2 e3) = liftM4 OpApp@@ -618,10 +620,6 @@ addTickHsExpr (HsBinTick x t0 t1 e) = liftM (HsBinTick x t0 t1) (addTickLHsExprNever e) -addTickHsExpr (HsPragE _ HsPragTick{} (L pos e0)) = do- e2 <- allocTickBox (ExpBox False) False False pos $- addTickHsExpr e0- return $ unLoc e2 addTickHsExpr (HsPragE x p e) = liftM (HsPragE x p) (addTickLHsExpr e) addTickHsExpr e@(HsBracket {}) = return e@@ -1338,8 +1336,7 @@ ] where platform = targetPlatform dflags- bcknd = backend dflags- tickboxes = pprCLabel bcknd platform (mkHpcTicksLabel $ this_mod)+ tickboxes = pprCLabel platform CStyle (mkHpcTicksLabel $ this_mod) module_name = hcat (map (text.charToC) $ BS.unpack $ bytesFS (moduleNameFS (moduleName this_mod)))
compiler/GHC/HsToCore/Docs.hs view
@@ -193,13 +193,19 @@ , (L _ (ConDeclField _ ns _ doc)) <- (unLoc flds) , (L _ n) <- ns ] derivs = [ (instName, [unLoc doc], M.empty)- | (l, doc) <- mapMaybe (extract_deriv_ty . hsib_body) $- concatMap (unLoc . deriv_clause_tys . unLoc) $+ | (l, doc) <- concatMap (extract_deriv_clause_tys .+ deriv_clause_tys . unLoc) $ unLoc $ dd_derivs dd , Just instName <- [lookupSrcSpan l instMap] ] - extract_deriv_ty :: LHsType GhcRn -> Maybe (SrcSpan, LHsDocString)- extract_deriv_ty (L l ty) =+ extract_deriv_clause_tys :: LDerivClauseTys GhcRn -> [(SrcSpan, LHsDocString)]+ extract_deriv_clause_tys (L _ dct) =+ case dct of+ DctSingle _ ty -> maybeToList $ extract_deriv_ty ty+ DctMulti _ tys -> mapMaybe extract_deriv_ty tys++ extract_deriv_ty :: LHsSigType GhcRn -> Maybe (SrcSpan, LHsDocString)+ extract_deriv_ty (HsIB{hsib_body = L l ty}) = case ty of -- deriving (forall a. C a {- ^ Doc comment -}) HsForAllTy{ hst_tele = HsForAllInvis{}
compiler/GHC/HsToCore/Expr.hs view
@@ -31,7 +31,7 @@ import GHC.HsToCore.Utils import GHC.HsToCore.Arrows import GHC.HsToCore.Monad-import GHC.HsToCore.PmCheck ( addTyCsDs, checkGRHSs )+import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs ) import GHC.Types.Name import GHC.Types.Name.Env import GHC.Core.FamInstEnv( topNormaliseType )@@ -215,8 +215,8 @@ , pat_ext = ty }) body = -- let C x# y# = rhs in body -- ==> case rhs of C x# y# -> body- do { match_deltas <- checkGRHSs PatBindGuards grhss- ; rhs <- dsGuarded grhss ty match_deltas+ do { match_nablas <- pmcGRHSs PatBindGuards grhss+ ; rhs <- dsGuarded grhss ty match_nablas ; let upat = unLoc pat eqn = EqnInfo { eqn_pats = [upat], eqn_orig = FromSource,@@ -261,10 +261,14 @@ ; return e' } dsExpr :: HsExpr GhcTc -> DsM CoreExpr+dsExpr (HsVar _ (L _ id)) = dsHsVar id+dsExpr (HsRecFld _ (Unambiguous id _)) = dsHsVar id+dsExpr (HsRecFld _ (Ambiguous id _)) = dsHsVar id+dsExpr (HsUnboundVar id _) = dsHsVar id+ dsExpr (HsPar _ e) = dsLExpr e dsExpr (ExprWithTySig _ e _) = dsLExpr e-dsExpr (HsVar _ (L _ var)) = dsHsVar var-dsExpr (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them+ dsExpr (HsConLikeOut _ con) = dsConLike con dsExpr (HsIPVar {}) = panic "dsExpr: HsIPVar" dsExpr (HsOverLabel{}) = panic "dsExpr: HsOverLabel"@@ -283,7 +287,7 @@ HsConLikeOut _ (RealDataCon dc) -> return $ varToCoreExpr (dataConWrapId dc) XExpr (WrapExpr (HsWrap _ _)) -> pprPanic "dsExpr: HsWrap inside HsWrap" (ppr hswrap) HsPar _ _ -> pprPanic "dsExpr: HsPar inside HsWrap" (ppr hswrap)- _ -> addTyCsDs FromSource (hsWrapDictBinders co_fn) $+ _ -> addTyCs FromSource (hsWrapDictBinders co_fn) $ dsExpr e -- See Note [Detecting forced eta expansion] ; wrap' <- dsHsWrapper co_fn@@ -486,8 +490,8 @@ | otherwise = do { let grhss = GRHSs noExtField alts (noLoc emptyLocalBinds)- ; rhss_deltas <- checkGRHSs IfAlt grhss- ; match_result <- dsGRHSs IfAlt grhss res_ty rhss_deltas+ ; rhss_nablas <- pmcGRHSs IfAlt grhss+ ; match_result <- dsGRHSs IfAlt grhss res_ty rhss_nablas ; error_expr <- mkErrorExpr ; extractMatchResult match_result error_expr } where@@ -806,7 +810,6 @@ -- HsSyn constructs that just shouldn't be here: dsExpr (HsBracket {}) = panic "dsExpr:HsBracket" dsExpr (HsDo {}) = panic "dsExpr:HsDo"-dsExpr (HsRecFld {}) = panic "dsExpr:HsRecFld" ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr ds_prag_expr (HsPragSCC _ _ cc) expr = do@@ -816,15 +819,10 @@ mod_name <- getModule count <- goptM Opt_ProfCountEntries let nm = sl_fs cc- flavour <- ExprCC <$> getCCIndexM nm+ flavour <- ExprCC <$> getCCIndexDsM nm Tick (ProfNote (mkUserCC nm mod_name (getLoc expr) flavour) count True) <$> dsLExpr expr else dsLExpr expr-ds_prag_expr (HsPragTick _ _ _ _) expr = do- dflags <- getDynFlags- if gopt Opt_Hpc dflags- then panic "dsExpr:HsPragTick"- else dsLExpr expr ------------------------------ dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr@@ -986,7 +984,7 @@ = do { body <- goL stmts ; rhs' <- dsLExpr rhs ; var <- selectSimpleMatchVarL (xbstc_boundResultMult xbs) pat- ; match <- matchSinglePatVar var (StmtCtxt ctx) pat+ ; match <- matchSinglePatVar var Nothing (StmtCtxt ctx) pat (xbstc_boundResultType xbs) (cantFailMatchResult body) ; match_code <- dsHandleMonadicFailure ctx pat match (xbstc_failOp xbs) ; dsSyntaxExpr (xbstc_bindOp xbs) [rhs', Lam var match_code] }@@ -1007,7 +1005,7 @@ ; let match_args (pat, fail_op) (vs,body) = do { var <- selectSimpleMatchVarL Many pat- ; match <- matchSinglePatVar var (StmtCtxt ctx) pat+ ; match <- matchSinglePatVar var Nothing (StmtCtxt ctx) pat body_ty (cantFailMatchResult body) ; match_code <- dsHandleMonadicFailure ctx pat match fail_op ; return (var:vs, match_code)
compiler/GHC/HsToCore/Foreign/Decl.hs view
@@ -27,7 +27,7 @@ import GHC.Hs import GHC.Core.DataCon-import GHC.Core.Unfold+import GHC.Core.Unfold.Make import GHC.Types.Id import GHC.Types.Literal import GHC.Unit.Module@@ -53,6 +53,7 @@ import GHC.Utils.Outputable import GHC.Data.FastString import GHC.Driver.Session+import GHC.Driver.Config import GHC.Platform import GHC.Data.OrdList import GHC.Utils.Misc@@ -90,15 +91,16 @@ dsForeigns' [] = return (NoStubs, nilOL) dsForeigns' fos = do+ mod <- getModule fives <- mapM do_ldecl fos let (hs, cs, idss, bindss) = unzip4 fives fe_ids = concat idss- fe_init_code = map foreignExportInitialiser fe_ids+ fe_init_code = foreignExportsInitialiser mod fe_ids -- return (ForeignStubs (vcat hs)- (vcat cs $$ vcat fe_init_code),+ (vcat cs $$ fe_init_code), foldr (appOL . toOL) nilOL bindss) where do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl)@@ -286,8 +288,11 @@ wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers wrap_rhs = mkLams (tvs ++ args) wrapper_body wrap_rhs' = Cast wrap_rhs co+ simpl_opts = initSimpleOpts dflags fn_id_w_inl = fn_id `setIdUnfolding` mkInlineUnfoldingWithArity- (length args) wrap_rhs'+ (length args)+ simpl_opts+ wrap_rhs' return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], empty, cDoc) @@ -696,8 +701,8 @@ ] -foreignExportInitialiser :: Id -> SDoc-foreignExportInitialiser hs_fn =+foreignExportsInitialiser :: Module -> [Id] -> SDoc+foreignExportsInitialiser mod hs_fns = -- Initialise foreign exports by registering a stable pointer from an -- __attribute__((constructor)) function. -- The alternative is to do this from stginit functions generated in@@ -706,14 +711,24 @@ -- all modules that are imported directly or indirectly are actually used by -- the program. -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL)+ --+ -- See Note [Tracking foreign exports] in rts/ForeignExports.c vcat- [ text "static void stginit_export_" <> ppr hs_fn- <> text "() __attribute__((constructor));"- , text "static void stginit_export_" <> ppr hs_fn <> text "()"- , braces (text "foreignExportStablePtr"- <> parens (text "(StgPtr) &" <> ppr hs_fn <> text "_closure")- <> semi)+ [ text "static struct ForeignExportsList" <+> list_symbol <+> equals+ <+> braces (text ".exports = " <+> export_list) <> semi+ , text "static void " <> ctor_symbol <> text "(void)"+ <+> text " __attribute__((constructor));"+ , text "static void " <> ctor_symbol <> text "()"+ , braces (text "registerForeignExports" <> parens (char '&' <> list_symbol) <> semi) ]+ where+ mod_str = pprModuleName (moduleName mod)+ ctor_symbol = text "stginit_export_" <> mod_str+ list_symbol = text "stg_exports_" <> mod_str+ export_list = braces $ pprWithCommas closure_ptr hs_fns++ closure_ptr :: Id -> SDoc+ closure_ptr fn = text "(StgPtr) &" <> ppr fn <> text "_closure" mkHObj :: Type -> SDoc
compiler/GHC/HsToCore/GuardedRHSs.hs view
@@ -25,7 +25,7 @@ import GHC.HsToCore.Monad import GHC.HsToCore.Utils-import GHC.HsToCore.PmCheck.Types ( Deltas )+import GHC.HsToCore.Pmc.Types ( Nablas ) import GHC.Core.Type ( Type ) import GHC.Utils.Misc import GHC.Types.SrcLoc@@ -36,7 +36,7 @@ import Data.List.NonEmpty ( NonEmpty, toList ) {--@dsGuarded@ is used for pattern bindings.+@dsGuarded@ is used for GRHSs. It desugars: \begin{verbatim} | g1 -> e1@@ -44,13 +44,13 @@ | gn -> en where binds \end{verbatim}-producing an expression with a runtime error in the corner if+producing an expression with a runtime error in the corner case if necessary. The type argument gives the type of the @ei@. -} -dsGuarded :: GRHSs GhcTc (LHsExpr GhcTc) -> Type -> NonEmpty Deltas -> DsM CoreExpr-dsGuarded grhss rhs_ty rhss_deltas = do- match_result <- dsGRHSs PatBindRhs grhss rhs_ty rhss_deltas+dsGuarded :: GRHSs GhcTc (LHsExpr GhcTc) -> Type -> NonEmpty Nablas -> DsM CoreExpr+dsGuarded grhss rhs_ty rhss_nablas = do+ match_result <- dsGRHSs PatBindRhs grhss rhs_ty rhss_nablas error_expr <- mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID rhs_ty empty extractMatchResult match_result error_expr @@ -59,28 +59,28 @@ dsGRHSs :: HsMatchContext GhcRn -> GRHSs GhcTc (LHsExpr GhcTc) -- ^ Guarded RHSs -> Type -- ^ Type of RHS- -> NonEmpty Deltas -- ^ Refined pattern match checking+ -> NonEmpty Nablas -- ^ Refined pattern match checking -- models, one for the pattern part and -- one for each GRHS. -> DsM (MatchResult CoreExpr)-dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty rhss_deltas+dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty rhss_nablas = ASSERT( notNull grhss )- do { match_results <- ASSERT( length grhss == length rhss_deltas )- zipWithM (dsGRHS hs_ctx rhs_ty) (toList rhss_deltas) grhss- ; deltas <- getPmDeltas- -- We need to remember the Deltas from the particular match context we+ do { match_results <- ASSERT( length grhss == length rhss_nablas )+ zipWithM (dsGRHS hs_ctx rhs_ty) (toList rhss_nablas) grhss+ ; nablas <- getPmNablas+ -- We need to remember the Nablas from the particular match context we -- are in, which might be different to when dsLocalBinds is actually -- called.- ; let ds_binds = updPmDeltas deltas . dsLocalBinds binds+ ; let ds_binds = updPmNablas nablas . dsLocalBinds binds match_result1 = foldr1 combineMatchResults match_results match_result2 = adjustMatchResultDs ds_binds match_result1 -- NB: nested dsLet inside matchResult ; return match_result2 } -dsGRHS :: HsMatchContext GhcRn -> Type -> Deltas -> LGRHS GhcTc (LHsExpr GhcTc)+dsGRHS :: HsMatchContext GhcRn -> Type -> Nablas -> LGRHS GhcTc (LHsExpr GhcTc) -> DsM (MatchResult CoreExpr)-dsGRHS hs_ctx rhs_ty rhs_deltas (L _ (GRHS _ guards rhs))- = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs_deltas rhs rhs_ty+dsGRHS hs_ctx rhs_ty rhs_nablas (L _ (GRHS _ guards rhs))+ = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs_nablas rhs rhs_ty {- ************************************************************************@@ -92,7 +92,7 @@ matchGuards :: [GuardStmt GhcTc] -- Guard -> HsStmtContext GhcRn -- Context- -> Deltas -- The RHS's covered set for PmCheck+ -> Nablas -- The RHS's covered set for PmCheck -> LHsExpr GhcTc -- RHS -> Type -- Type of RHS of guard -> DsM (MatchResult CoreExpr)@@ -100,8 +100,8 @@ -- See comments with HsExpr.Stmt re what a BodyStmt means -- Here we must be in a guard context (not do-expression, nor list-comp) -matchGuards [] _ deltas rhs _- = do { core_rhs <- updPmDeltas deltas (dsLExpr rhs)+matchGuards [] _ nablas rhs _+ = do { core_rhs <- updPmNablas nablas (dsLExpr rhs) ; return (cantFailMatchResult core_rhs) } -- BodyStmts must be guards@@ -111,34 +111,34 @@ -- NB: The success of this clause depends on the typechecker not -- wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors -- If it does, you'll get bogus overlap warnings-matchGuards (BodyStmt _ e _ _ : stmts) ctx deltas rhs rhs_ty+matchGuards (BodyStmt _ e _ _ : stmts) ctx nablas rhs rhs_ty | Just addTicks <- isTrueLHsExpr e = do- match_result <- matchGuards stmts ctx deltas rhs rhs_ty+ match_result <- matchGuards stmts ctx nablas rhs rhs_ty return (adjustMatchResultDs addTicks match_result)-matchGuards (BodyStmt _ expr _ _ : stmts) ctx deltas rhs rhs_ty = do- match_result <- matchGuards stmts ctx deltas rhs rhs_ty+matchGuards (BodyStmt _ expr _ _ : stmts) ctx nablas rhs rhs_ty = do+ match_result <- matchGuards stmts ctx nablas rhs rhs_ty pred_expr <- dsLExpr expr return (mkGuardedMatchResult pred_expr match_result) -matchGuards (LetStmt _ binds : stmts) ctx deltas rhs rhs_ty = do- match_result <- matchGuards stmts ctx deltas rhs rhs_ty+matchGuards (LetStmt _ binds : stmts) ctx nablas rhs rhs_ty = do+ match_result <- matchGuards stmts ctx nablas rhs rhs_ty return (adjustMatchResultDs (dsLocalBinds binds) match_result) -- NB the dsLet occurs inside the match_result -- Reason: dsLet takes the body expression as its argument -- so we can't desugar the bindings without the -- body expression in hand -matchGuards (BindStmt _ pat bind_rhs : stmts) ctx deltas rhs rhs_ty = do+matchGuards (BindStmt _ pat bind_rhs : stmts) ctx nablas rhs rhs_ty = do let upat = unLoc pat match_var <- selectMatchVar Many upat -- We only allow unrestricted patterns in guard, hence the `Many` -- above. It isn't clear what linear patterns would mean, maybe we will -- figure it out in the future. - match_result <- matchGuards stmts ctx deltas rhs rhs_ty+ match_result <- matchGuards stmts ctx nablas rhs rhs_ty core_rhs <- dsLExpr bind_rhs- match_result' <- matchSinglePatVar match_var (StmtCtxt ctx) pat rhs_ty- match_result+ match_result' <- matchSinglePatVar match_var (Just core_rhs) (StmtCtxt ctx)+ pat rhs_ty match_result pure $ bindNonRec match_var core_rhs <$> match_result' matchGuards (LastStmt {} : _) _ _ _ _ = panic "matchGuards LastStmt"
compiler/GHC/HsToCore/ListComp.hs view
@@ -617,7 +617,7 @@ dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts = do { body <- dsMcStmts stmts ; var <- selectSimpleMatchVarL Many pat- ; match <- matchSinglePatVar var (StmtCtxt (DoExpr Nothing)) pat+ ; match <- matchSinglePatVar var Nothing (StmtCtxt (DoExpr Nothing)) pat res1_ty (cantFailMatchResult body) ; match_code <- dsHandleMonadicFailure (MonadComp :: HsStmtContext GhcRn) pat match fail_op ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
compiler/GHC/HsToCore/Match.hs view
@@ -34,8 +34,8 @@ import GHC.Tc.Utils.Zonk import GHC.Tc.Types.Evidence import GHC.Tc.Utils.Monad-import GHC.HsToCore.PmCheck-import GHC.HsToCore.PmCheck.Types ( Deltas, initDeltas )+import GHC.HsToCore.Pmc+import GHC.HsToCore.Pmc.Types ( Nablas, initNablas ) import GHC.Core import GHC.Types.Literal import GHC.Core.Utils@@ -66,7 +66,7 @@ import GHC.Types.Unique import GHC.Types.Unique.DFM -import Control.Monad(zipWithM, unless )+import Control.Monad ( zipWithM, unless, when ) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as Map@@ -766,31 +766,31 @@ (hsLMatchPats m)) -- Pattern match check warnings for /this match-group/.- -- @rhss_deltas@ is a flat list of covered Deltas for each RHS.- -- Each Match will split off one Deltas for its RHSs from this.- ; matches_deltas <- if isMatchContextPmChecked dflags origin ctxt- then addScrutTmCs mb_scr new_vars $- -- See Note [Type and Term Equality Propagation]- checkMatches (DsMatchContext ctxt locn) new_vars matches- else pure (initDeltasMatches matches)+ -- @rhss_nablas@ is a flat list of covered Nablas for each RHS.+ -- Each Match will split off one Nablas for its RHSs from this.+ ; matches_nablas <- if isMatchContextPmChecked dflags origin ctxt+ then addHsScrutTmCs mb_scr new_vars $+ -- See Note [Long-distance information]+ pmcMatches (DsMatchContext ctxt locn) new_vars matches+ else pure (initNablasMatches matches) - ; eqns_info <- zipWithM mk_eqn_info matches matches_deltas+ ; eqns_info <- zipWithM mk_eqn_info matches matches_nablas ; result_expr <- handleWarnings $ matchEquations ctxt new_vars eqns_info rhs_ty ; return (new_vars, result_expr) } where -- Called once per equation in the match, or alternative in the case- mk_eqn_info :: LMatch GhcTc (LHsExpr GhcTc) -> (Deltas, NonEmpty Deltas) -> DsM EquationInfo- mk_eqn_info (L _ (Match { m_pats = pats, m_grhss = grhss })) (pat_deltas, rhss_deltas)+ mk_eqn_info :: LMatch GhcTc (LHsExpr GhcTc) -> (Nablas, NonEmpty Nablas) -> DsM EquationInfo+ mk_eqn_info (L _ (Match { m_pats = pats, m_grhss = grhss })) (pat_nablas, rhss_nablas) = do { dflags <- getDynFlags ; let upats = map (unLoc . decideBangHood dflags) pats- -- pat_deltas is the covered set *after* matching the pattern, but- -- before any of the GRHSs. We extend the environment with pat_deltas- -- (via updPmDeltas) so that the where-clause of 'grhss' can profit+ -- pat_nablas is the covered set *after* matching the pattern, but+ -- before any of the GRHSs. We extend the environment with pat_nablas+ -- (via updPmNablas) so that the where-clause of 'grhss' can profit -- from that knowledge (#18533)- ; match_result <- updPmDeltas pat_deltas $- dsGRHSs ctxt grhss rhs_ty rhss_deltas+ ; match_result <- updPmNablas pat_nablas $+ dsGRHSs ctxt grhss rhs_ty rhss_nablas ; return EqnInfo { eqn_pats = upats , eqn_orig = FromSource , eqn_rhs = match_result } }@@ -799,14 +799,14 @@ then discardWarningsDs else id - initDeltasMatches :: [LMatch GhcTc b] -> [(Deltas, NonEmpty Deltas)]- initDeltasMatches ms- = map (\(L _ m) -> (initDeltas, initDeltasGRHSs (m_grhss m))) ms+ initNablasMatches :: [LMatch GhcTc b] -> [(Nablas, NonEmpty Nablas)]+ initNablasMatches ms+ = map (\(L _ m) -> (initNablas, initNablasGRHSs (m_grhss m))) ms - initDeltasGRHSs :: GRHSs GhcTc b -> NonEmpty Deltas- initDeltasGRHSs m = expectJust "GRHSs non-empty"+ initNablasGRHSs :: GRHSs GhcTc b -> NonEmpty Nablas+ initNablasGRHSs m = expectJust "GRHSs non-empty" $ NEL.nonEmpty- $ replicate (length (grhssGRHSs m)) initDeltas+ $ replicate (length (grhssGRHSs m)) initNablas matchEquations :: HsMatchContext GhcRn@@ -820,25 +820,24 @@ ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc ; extractMatchResult match_result fail_expr } -{--************************************************************************-* *-\subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern}-* *-************************************************************************--@mkSimpleMatch@ is a wrapper for @match@ which deals with the-situation where we want to match a single expression against a single-pattern. It returns an expression.--}-+-- | @matchSimply@ is a wrapper for 'match' which deals with the+-- situation where we want to match a single expression against a single+-- pattern. It returns an expression. matchSimply :: CoreExpr -- ^ Scrutinee -> HsMatchContext GhcRn -- ^ Match kind -> LPat GhcTc -- ^ Pattern it should match -> CoreExpr -- ^ Return this if it matches -> CoreExpr -- ^ Return this if it doesn't -> DsM CoreExpr--- Do not warn about incomplete patterns; see matchSinglePat comments+-- Some reasons 'matchSimply' is not defined using 'matchWrapper' (#18572):+-- * Some call sites like in 'deBindComp' specify a @fail_expr@ that isn't a+-- straight @patError@+-- * It receives an already desugared 'CoreExpr' for the scrutinee, not an+-- 'HsExpr' like 'matchWrapper' expects+-- * Filling in all the phony fields for the 'MatchGroup' for a single pattern+-- match is awkward+-- * And we still export 'matchSinglePatVar', so not much is gained if we+-- don't also implement it in terms of 'matchWrapper' matchSimply scrut hs_ctx pat result_expr fail_expr = do let match_result = cantFailMatchResult result_expr@@ -858,7 +857,7 @@ matchSinglePat (Var var) ctx pat ty match_result | not (isExternalName (idName var))- = matchSinglePatVar var ctx pat ty match_result+ = matchSinglePatVar var Nothing ctx pat ty match_result matchSinglePat scrut hs_ctx pat ty match_result = do { var <- selectSimpleMatchVarL Many pat@@ -867,22 +866,22 @@ -- and to create field selectors. All of which only -- bind unrestricted variables, hence the 'Many' -- above.- ; match_result' <- matchSinglePatVar var hs_ctx pat ty match_result+ ; match_result' <- matchSinglePatVar var (Just scrut) hs_ctx pat ty match_result ; return $ bindNonRec var scrut <$> match_result' } matchSinglePatVar :: Id -- See Note [Match Ids]+ -> Maybe CoreExpr -- ^ The scrutinee the match id is bound to -> HsMatchContext GhcRn -> LPat GhcTc -> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr)-matchSinglePatVar var ctx pat ty match_result+matchSinglePatVar var mb_scrut ctx pat ty match_result = ASSERT2( isInternalName (idName var), ppr var ) do { dflags <- getDynFlags ; locn <- getSrcSpanDs- -- Pattern match check warnings- ; if isMatchContextPmChecked dflags FromSource ctx- then checkSingle dflags (DsMatchContext ctx locn) var (unLoc pat)- else pure ()+ ; when (isMatchContextPmChecked dflags FromSource ctx) $+ addCoreScrutTmCs mb_scrut [var] $+ pmcPatBind (DsMatchContext ctx locn) var (unLoc pat) ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)] , eqn_orig = FromSource
compiler/GHC/HsToCore/Match.hs-boot view
@@ -29,6 +29,7 @@ matchSinglePatVar :: Id+ -> Maybe CoreExpr -> HsMatchContext GhcRn -> LPat GhcTc -> Type
compiler/GHC/HsToCore/Monad.hs view
@@ -30,11 +30,12 @@ getGhcModeDs, dsGetFamInstEnvs, dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon, dsLookupConLike,+ getCCIndexDsM, DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv, -- Getting and setting pattern match oracle states- getPmDeltas, updPmDeltas,+ getPmNablas, updPmNablas, -- Get COMPLETE sets of a TyCon dsGetCompleteMatches,@@ -73,7 +74,8 @@ import GHC.Core.DataCon import GHC.Core.ConLike import GHC.Core.TyCon-import GHC.HsToCore.PmCheck.Types+import GHC.HsToCore.Types+import GHC.HsToCore.Pmc.Solver.Types (Nablas, initNablas) import GHC.Types.Id import GHC.Unit.Module import GHC.Utils.Outputable@@ -88,7 +90,6 @@ import GHC.Utils.Error import GHC.Utils.Panic import GHC.Data.FastString-import GHC.Types.Unique.FM ( lookupWithDefaultUFM_Directly ) import GHC.Types.Literal ( mkLitString ) import GHC.Types.CostCentre.State @@ -210,13 +211,15 @@ -> m (DsGblEnv, DsLclEnv) mkDsEnvsFromTcGbl hsc_env msg_var tcg_env = do { cc_st_var <- liftIO $ newIORef newCostCentreState+ ; eps <- liftIO $ hscEPS hsc_env ; let dflags = hsc_dflags hsc_env this_mod = tcg_mod tcg_env type_env = tcg_type_env tcg_env rdr_env = tcg_rdr_env tcg_env fam_inst_env = tcg_fam_inst_env tcg_env- complete_matches = hptCompleteSigs hsc_env- ++ tcg_complete_matches tcg_env+ complete_matches = hptCompleteSigs hsc_env -- from the home package+ ++ tcg_complete_matches tcg_env -- from the current module+ ++ eps_complete_matches eps -- from imports ; return $ mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env msg_var cc_st_var complete_matches }@@ -239,13 +242,15 @@ initDsWithModGuts hsc_env guts thing_inside = do { cc_st_var <- newIORef newCostCentreState ; msg_var <- newIORef emptyMessages+ ; eps <- liftIO $ hscEPS hsc_env ; let dflags = hsc_dflags hsc_env type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts) rdr_env = mg_rdr_env guts fam_inst_env = mg_fam_inst_env guts this_mod = mg_module guts- complete_matches = hptCompleteSigs hsc_env- ++ mg_complete_sigs guts+ complete_matches = hptCompleteSigs hsc_env -- from the home package+ ++ mg_complete_matches guts -- from the current module+ ++ eps_complete_matches eps -- from imports bindsToIds (NonRec v _) = [v] bindsToIds (Rec binds) = map fst binds@@ -281,7 +286,7 @@ thing_inside } mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv- -> IORef Messages -> IORef CostCentreState -> [CompleteMatch]+ -> IORef Messages -> IORef CostCentreState -> CompleteMatches -> (DsGblEnv, DsLclEnv) mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var cc_st_var complete_matches@@ -290,7 +295,6 @@ if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod) NotBoot real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1)- completeMatchMap = mkCompleteMatchMap complete_matches gbl_env = DsGblEnv { ds_mod = mod , ds_fam_inst_env = fam_inst_env , ds_if_env = (if_genv, if_lenv)@@ -299,12 +303,12 @@ (mkHomeUnitFromFlags dflags) rdr_env , ds_msgs = msg_var- , ds_complete_matches = completeMatchMap+ , ds_complete_matches = complete_matches , ds_cc_st = cc_st_var } lcl_env = DsLclEnv { dsl_meta = emptyNameEnv , dsl_loc = real_span- , dsl_deltas = initDeltas+ , dsl_nablas = initNablas } in (gbl_env, lcl_env) @@ -403,14 +407,14 @@ getGhcModeDs :: DsM GhcMode getGhcModeDs = getDynFlags >>= return . ghcMode --- | Get the current pattern match oracle state. See 'dsl_deltas'.-getPmDeltas :: DsM Deltas-getPmDeltas = do { env <- getLclEnv; return (dsl_deltas env) }+-- | Get the current pattern match oracle state. See 'dsl_nablas'.+getPmNablas :: DsM Nablas+getPmNablas = do { env <- getLclEnv; return (dsl_nablas env) } -- | Set the pattern match oracle state within the scope of the given action.--- See 'dsl_deltas'.-updPmDeltas :: Deltas -> DsM a -> DsM a-updPmDeltas deltas = updLclEnv (\env -> env { dsl_deltas = deltas })+-- See 'dsl_nablas'.+updPmNablas :: Nablas -> DsM a -> DsM a+updPmNablas nablas = updLclEnv (\env -> env { dsl_nablas = nablas }) getSrcSpanDs :: DsM SrcSpan getSrcSpanDs = do { env <- getLclEnv@@ -533,18 +537,9 @@ dsGetMetaEnv :: DsM (NameEnv DsMetaVal) dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) } --- | The @COMPLETE@ pragmas provided by the user for a given `TyCon`.-dsGetCompleteMatches :: TyCon -> DsM [CompleteMatch]-dsGetCompleteMatches tc = do- eps <- getEps- env <- getGblEnv- -- We index into a UniqFM from Name -> elt, for tyCon it holds that- -- getUnique (tyConName tc) == getUnique tc. So we lookup using the- -- unique directly instead.- let lookup_completes ufm = lookupWithDefaultUFM_Directly ufm [] (getUnique tc)- eps_matches_list = lookup_completes $ eps_complete_matches eps- env_matches_list = lookup_completes $ ds_complete_matches env- return $ eps_matches_list ++ env_matches_list+-- | The @COMPLETE@ pragmas that are in scope.+dsGetCompleteMatches :: DsM CompleteMatches+dsGetCompleteMatches = ds_complete_matches <$> getGblEnv dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal) dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (dsl_meta env) name) }@@ -621,3 +616,7 @@ message = App (Var unpackCStringId) $ Lit $ mkLitString $ showSDoc dflags (hang (text str) 4 doc) return $ mkApps (Var traceId) [Type (exprType expr), message, expr]++-- | See 'getCCIndexM'.+getCCIndexDsM :: FastString -> DsM CostCentreIndex+getCCIndexDsM = getCCIndexM ds_cc_st
− compiler/GHC/HsToCore/PmCheck.hs
@@ -1,1421 +0,0 @@-{--Author: George Karachalias <george.karachalias@cs.kuleuven.be>--Pattern Matching Coverage Checking.--}--{-# LANGUAGE CPP #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-}--module GHC.HsToCore.PmCheck (- -- Checking and printing- checkSingle, checkMatches, checkGRHSs,- isMatchContextPmChecked,-- -- See Note [Type and Term Equality Propagation]- addTyCsDs, addScrutTmCs- ) where--#include "GhclibHsVersions.h"--import GHC.Prelude--import GHC.HsToCore.PmCheck.Types-import GHC.HsToCore.PmCheck.Oracle-import GHC.HsToCore.PmCheck.Ppr-import GHC.Types.Basic (Origin(..), isGenerated)-import GHC.Core (CoreExpr, Expr(Var,App))-import GHC.Data.FastString (unpackFS, lengthFS)-import GHC.Driver.Session-import GHC.Hs-import GHC.Tc.Utils.Zonk (shortCutLit)-import GHC.Types.Id-import GHC.Core.ConLike-import GHC.Types.Name-import GHC.Tc.Instance.Family-import GHC.Builtin.Types-import GHC.Types.SrcLoc-import GHC.Utils.Misc-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Core.DataCon-import GHC.Core.TyCon-import GHC.Types.Var (EvVar)-import GHC.Core.Coercion-import GHC.Tc.Types.Evidence (HsWrapper(..), isIdHsWrapper)-import GHC.Tc.Utils.TcType (evVarPred)-import {-# SOURCE #-} GHC.HsToCore.Expr (dsExpr, dsLExpr, dsSyntaxExpr)-import {-# SOURCE #-} GHC.HsToCore.Binds (dsHsWrapper)-import GHC.HsToCore.Utils (selectMatchVar)-import GHC.HsToCore.Match.Literal (dsLit, dsOverLit)-import GHC.HsToCore.Monad-import GHC.Data.Bag-import GHC.Data.IOEnv (unsafeInterleaveM)-import GHC.Data.OrdList-import GHC.Core.TyCo.Rep-import GHC.Core.Type-import GHC.HsToCore.Utils (isTrueLHsExpr)-import GHC.Data.Maybe-import qualified GHC.LanguageExtensions as LangExt-import GHC.Utils.Monad (concatMapM)--import Control.Monad (when, forM_, zipWithM)-import Data.List (elemIndex)-import qualified Data.Semigroup as Semi-import Data.List.NonEmpty (NonEmpty(..))--{--This module checks pattern matches for:-\begin{enumerate}- \item Equations that are redundant- \item Equations with inaccessible right-hand-side- \item Exhaustiveness-\end{enumerate}--The algorithm is based on the paper:-- "GADTs Meet Their Match:- Pattern-matching Warnings That Account for GADTs, Guards, and Laziness"-- https://www.microsoft.com/en-us/research/wp-content/uploads/2016/08/gadtpm-acm.pdf--%************************************************************************-%* *- Pattern Match Check Types-%* *-%************************************************************************--}---- | A very simple language for pattern guards. Let bindings, bang patterns,--- and matching variables against flat constructor patterns.-data PmGrd- = -- | @PmCon x K dicts args@ corresponds to a @K dicts args <- x@ guard.- -- The @args@ are bound in this construct, the @x@ is just a use.- -- For the arguments' meaning see 'GHC.Hs.Pat.ConPatOut'.- PmCon {- pm_id :: !Id,- pm_con_con :: !PmAltCon,- pm_con_tvs :: ![TyVar],- pm_con_dicts :: ![EvVar],- pm_con_args :: ![Id]- }-- -- | @PmBang x@ corresponds to a @seq x True@ guard.- -- If the extra SrcInfo is present, the bang guard came from a source- -- bang pattern, in which case we might want to report it as redundant,- -- see Note [Dead bang patterns].- | PmBang {- pm_id :: !Id,- pm_loc :: !(Maybe SrcInfo)- }-- -- | @PmLet x expr@ corresponds to a @let x = expr@ guard. This actually- -- /binds/ @x@.- | PmLet {- pm_id :: !Id,- _pm_let_expr :: !CoreExpr- }---- | Should not be user-facing.-instance Outputable PmGrd where- ppr (PmCon x alt _tvs _con_dicts con_args)- = hsep [ppr alt, hsep (map ppr con_args), text "<-", ppr x]- ppr (PmBang x _loc) = char '!' <> ppr x- ppr (PmLet x expr) = hsep [text "let", ppr x, text "=", ppr expr]--type GrdVec = [PmGrd]--data Precision = Approximate | Precise- deriving (Eq, Show)--instance Outputable Precision where- ppr = text . show--instance Semi.Semigroup Precision where- Precise <> Precise = Precise- _ <> _ = Approximate--instance Monoid Precision where- mempty = Precise- mappend = (Semi.<>)---- | Means by which we identify source location for later pretty-printing--- in a warning message. 'SDoc' for the equation to show, 'Located' for--- the location.-type SrcInfo = Located SDoc---- | A representation of the desugaring to 'PmGrd's of all clauses of a--- function definition/pattern match/etc.-data GrdTree- = Rhs !SrcInfo- | Guard !PmGrd !GrdTree- -- ^ @Guard grd t@ will try to match @grd@ and on success continue to match- -- @t@. Falls through if either match fails. Models left-to-right semantics- -- of pattern matching.- | Sequence ![GrdTree]- -- ^ @Sequence (t:ts)@ matches against @t@, and then matches all- -- fallen-through values against @Sequence ts@. Models top-to-bottom semantics- -- of pattern matching.- -- @Sequence []@ always fails; it is useful for Note [Checking EmptyCase].--{- Note [Dead bang patterns]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-- f :: Bool -> Int- f True = 1- f !x = 2--Whenever we fall through to the second equation, we will already have evaluated-the argument. Thus, the bang pattern serves no purpose and should be warned-about. We call this kind of bang patterns "dead". Dead bangs are the ones-that under no circumstances can force a thunk that wasn't already forced.-Dead bangs are a form of redundant bangs; see below.--We can detect dead bang patterns by checking whether @x ~ ⊥@ is satisfiable-where the PmBang appears in 'checkGrdTree'. If not, then clearly the bang is-dead. Such a dead bang is then indicated in the annotated pattern-match tree by-a 'RedundantSrcBang' wrapping. In 'redundantAndInaccessibles', we collect-all dead bangs to warn about.--Note that we don't want to warn for a dead bang that appears on a redundant-clause. That is because in that case, we recommend to delete the clause wholly,-including its leading pattern match.--Dead bang patterns are redundant. But there are bang patterns which are-redundant that aren't dead, for example-- f !() = 0--the bang still forces the match variable, before we attempt to match on (). But-it is redundant with the forcing done by the () match. We currently don't-detect redundant bangs that aren't dead.--}---- | The digest of 'checkGrdTree', representing the annotated pattern-match--- tree. 'extractRedundancyInfo' can figure out redundant and proper--- inaccessible RHSs from this, as well as dead bangs.-data AnnotatedTree- = AccessibleRhs !Deltas !SrcInfo- -- ^ A RHS deemed accessible. The 'Deltas' is the (non-empty) set of covered- -- values.- | InaccessibleRhs !SrcInfo- -- ^ A RHS deemed inaccessible; it covers no value.- | MayDiverge !AnnotatedTree- -- ^ Asserts that the tree may force diverging values, so not all of its- -- clauses can be redundant.- | SequenceAnn !Deltas ![AnnotatedTree]- -- ^ @SequenceAnn inc ts@ mirrors @'Sequence' ts@ for preserving the- -- skeleton of a 'GrdTree's @ts@. It also carries the set of incoming values- -- @inc@.- | RedundantSrcBang !SrcInfo !AnnotatedTree- -- ^ For tracking redundant bangs. See Note [Dead bang patterns]--pprSrcInfo :: SrcInfo -> SDoc-pprSrcInfo (L (RealSrcSpan rss _) _) = ppr (srcSpanStartLine rss)-pprSrcInfo (L s _) = ppr s--instance Outputable GrdTree where- ppr (Rhs info) = text "->" <+> pprSrcInfo info- -- Format guards as "| True <- x, let x = 42, !z"- ppr g@Guard{} = fsep (prefix (map ppr grds)) <+> ppr t- where- (t, grds) = collect_grds g- collect_grds (Guard grd t) = (grd :) <$> collect_grds t- collect_grds t = (t, [])- prefix [] = []- prefix (s:sdocs) = char '|' <+> s : map (comma <+>) sdocs- ppr (Sequence []) = text "<empty case>"- ppr (Sequence ts) = braces (space <> fsep (punctuate semi (map ppr ts)) <> space)--instance Outputable AnnotatedTree where- ppr (AccessibleRhs _delta info) = parens (ppr _delta) <+> pprSrcInfo info- ppr (InaccessibleRhs info) = text "inaccessible" <+> pprSrcInfo info- ppr (MayDiverge t) = text "div" <+> ppr t- ppr (SequenceAnn _ []) = text "<empty case>"- ppr (SequenceAnn _ ts) = braces (space <> fsep (punctuate semi (map ppr ts)) <> space)- ppr (RedundantSrcBang l t) = text "redundant bang" <+> pprSrcInfo l <+> ppr t---- | Lift 'addPmCts' over 'Deltas'.-addPmCtsDeltas :: Deltas -> PmCts -> DsM Deltas-addPmCtsDeltas deltas cts = liftDeltasM (\d -> addPmCts d cts) deltas---- | 'addPmCtsDeltas' a single 'PmCt'.-addPmCtDeltas :: Deltas -> PmCt -> DsM Deltas-addPmCtDeltas deltas ct = addPmCtsDeltas deltas (unitBag ct)---- | Test if any of the 'Delta's is inhabited. Currently this is pure, because--- we preserve the invariant that there are no uninhabited 'Delta's. But that--- could change in the future, for example by implementing this function in--- terms of @notNull <$> provideEvidence 1 ds@.-isInhabited :: Deltas -> DsM Bool-isInhabited (MkDeltas ds) = pure (not (null ds))---- | Pattern-match check result-data CheckResult- = CheckResult- { cr_clauses :: !AnnotatedTree- -- ^ Captures redundancy info for each clause in the original program.- -- (for -Woverlapping-patterns)- , cr_uncov :: !Deltas- -- ^ The set of uncovered values falling out at the bottom.- -- (for -Wincomplete-patterns)- , cr_approx :: !Precision- -- ^ A flag saying whether we ran into the 'maxPmCheckModels' limit for the- -- purpose of suggesting to crank it up in the warning message- }--instance Outputable CheckResult where- ppr (CheckResult c unc pc)- = text "CheckResult" <+> ppr_precision pc <+> braces (fsep- [ field "clauses" c <> comma- , field "uncov" unc])- where- ppr_precision Precise = empty- ppr_precision Approximate = text "(Approximate)"- field name value = text name <+> equals <+> ppr value--{--%************************************************************************-%* *- Entry points to the checker: checkSingle and checkMatches-%* *-%************************************************************************--}---- | Check a single pattern binding (let) for exhaustiveness.-checkSingle :: DynFlags -> DsMatchContext -> Id -> Pat GhcTc -> DsM ()-checkSingle dflags ctxt@(DsMatchContext kind locn) var p = do- tracePm "checkSingle" (vcat [ppr ctxt, ppr var, ppr p])- -- We only ever need to run this in a context where we need exhaustivity- -- warnings (so not in pattern guards or comprehensions, for example, because- -- they are perfectly fine to fail).- -- Omitting checking this flag emits redundancy warnings twice in obscure- -- cases like #17646.- when (exhaustive dflags kind) $ do- -- TODO: This could probably call checkMatches, like checkGRHSs.- missing <- getPmDeltas- tracePm "checkSingle: missing" (ppr missing)- fam_insts <- dsGetFamInstEnvs- grd_tree <- mkGrdTreeRhs (L locn $ ppr p) <$> translatePat fam_insts var p- res <- checkGrdTree grd_tree missing- dsPmWarn dflags ctxt [var] res---- | Exhaustive for guard matches, is used for guards in pattern bindings and--- in @MultiIf@ expressions. Returns the 'Deltas' covered by the RHSs.-checkGRHSs- :: HsMatchContext GhcRn -- ^ Match context, for warning messages- -> GRHSs GhcTc (LHsExpr GhcTc) -- ^ The GRHSs to check- -> DsM (NonEmpty Deltas) -- ^ Covered 'Deltas' for each RHS, for long- -- distance info-checkGRHSs hs_ctx guards@(GRHSs _ grhss _) = do- let combinedLoc = foldl1 combineSrcSpans (map getLoc grhss)- dsMatchContext = DsMatchContext hs_ctx combinedLoc- match = L combinedLoc $- Match { m_ext = noExtField- , m_ctxt = hs_ctx- , m_pats = []- , m_grhss = guards }- [(_, deltas)] <- checkMatches dsMatchContext [] [match]- pure deltas---- | Check a list of syntactic /match/es (part of case, functions, etc.), each--- with a /pat/ and one or more /grhss/:------ @--- f x y | x == y = 1 -- match on x and y with two guarded RHSs--- | otherwise = 2--- f _ _ = 3 -- clause with a single, un-guarded RHS--- @------ Returns one 'Deltas' for each GRHS, representing its covered values, or the--- incoming uncovered 'Deltas' (from 'getPmDeltas') if the GRHS is inaccessible.--- Since there is at least one /grhs/ per /match/, the list of 'Deltas' is at--- least as long as the list of matches.-checkMatches- :: DsMatchContext -- ^ Match context, for warnings messages- -> [Id] -- ^ Match variables, i.e. x and y above- -> [LMatch GhcTc (LHsExpr GhcTc)] -- ^ List of matches- -> DsM [(Deltas, NonEmpty Deltas)] -- ^ One covered 'Deltas' per RHS, for long- -- distance info.-checkMatches ctxt vars matches = do- tracePm "checkMatches" (hang (vcat [ppr ctxt- , ppr vars- , text "Matches:"])- 2- (vcat (map ppr matches)))-- init_deltas <- getPmDeltas- missing <- case matches of- -- This must be an -XEmptyCase. See Note [Checking EmptyCase]- [] | [var] <- vars -> addPmCtDeltas init_deltas (PmNotBotCt var)- _ -> pure init_deltas- fam_insts <- dsGetFamInstEnvs- grd_tree <- translateMatches fam_insts vars matches- res <- checkGrdTree grd_tree missing-- dflags <- getDynFlags- dsPmWarn dflags ctxt vars res-- return (extractRhsDeltas (cr_clauses res))---- | Extract the 'Deltas' reaching the RHSs of the 'AnnotatedTree' for a match--- group.--- For 'AccessibleRhs's, this is stored in the tree node, whereas--- 'InaccessibleRhs's fall back to the supplied original 'Deltas'.--- See @Note [Recovering from unsatisfiable pattern-matching constraints]@.-extractRhsDeltas :: AnnotatedTree -> [(Deltas, NonEmpty Deltas)]-extractRhsDeltas = go_matches- where- go_matches :: AnnotatedTree -> [(Deltas, NonEmpty Deltas)]- go_matches (SequenceAnn def ts) = map (go_match def) ts -- -XEmptyCase handled here!- go_matches t = pprPanic "extractRhsDeltas.go_matches" (text "Matches must start with SequenceAnn. But was" $$ ppr t)-- go_match :: Deltas -> AnnotatedTree -> (Deltas, NonEmpty Deltas)- -- There is no -XEmptyCase at this level, only at the Matches level. So @ts@- -- is non-empty!- go_match def (SequenceAnn pat ts) = (pat, foldMap1 (text "go_match: empty SequenceAnn") (go_grhss def) ts)- go_match def (MayDiverge t) = go_match def t- go_match def (RedundantSrcBang _ t) = go_match def t- -- Even if there's only a single GRHS, we wrap it in a SequenceAnn for the- -- Deltas covered by the pattern. So the remaining cases are impossible!- go_match _ t = pprPanic "extractRhsDeltas.go_match" (text "Single GRHS must be wrapped in SequenceAnn. But got " $$ ppr t)-- go_grhss :: Deltas -> AnnotatedTree -> NonEmpty Deltas- -- There is no -XEmptyCase at this level, only at the Matches level. So @ts@- -- is non-empty!- go_grhss def (SequenceAnn _ ts) = foldMap1 (text "go_grhss: empty SequenceAnn") (go_grhss def) ts- go_grhss def (MayDiverge t) = go_grhss def t- go_grhss def (RedundantSrcBang _ t) = go_grhss def t- go_grhss _ (AccessibleRhs deltas _) = deltas :| []- go_grhss def (InaccessibleRhs _) = def :| []-- foldMap1 msg _ [] = pprPanic "extractRhsDeltas.foldMap1" msg- foldMap1 _ f (x:xs) = foldl' (\acc x -> acc Semi.<> f x) (f x) xs--{- Note [Checking EmptyCase]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~--XEmptyCase is useful for matching on empty data types like 'Void'. For example,-the following is a complete match:-- f :: Void -> ()- f x = case x of {}--Really, -XEmptyCase is the only way to write a program that at the same time is-safe (@f _ = error "boom"@ is not because of ⊥), doesn't trigger a warning-(@f !_ = error "inaccessible" has inaccessible RHS) and doesn't turn an-exception into divergence (@f x = f x@).--Semantically, unlike every other case expression, -XEmptyCase is strict in its-match var x, which rules out ⊥ as an inhabitant. So we add x /~ ⊥ to the-initial Delta and check if there are any values left to match on.--}--{--%************************************************************************-%* *- Transform source syntax to *our* syntax-%* *-%************************************************************************--}---- -------------------------------------------------------------------------- * Utilities---- | Smart constructor that eliminates trivial lets-mkPmLetVar :: Id -> Id -> GrdVec-mkPmLetVar x y | x == y = []-mkPmLetVar x y = [PmLet x (Var y)]---- | ADT constructor pattern => no existentials, no local constraints-vanillaConGrd :: Id -> DataCon -> [Id] -> PmGrd-vanillaConGrd scrut con arg_ids =- PmCon { pm_id = scrut, pm_con_con = PmAltConLike (RealDataCon con)- , pm_con_tvs = [], pm_con_dicts = [], pm_con_args = arg_ids }---- | Creates a 'GrdVec' refining a match var of list type to a list,--- where list fields are matched against the incoming tagged 'GrdVec's.--- For example:--- @mkListGrds "a" "[(x, True <- x),(y, !y)]"@--- to--- @"[(x:b) <- a, True <- x, (y:c) <- b, seq y True, [] <- c]"@--- where @b@ and @c@ are freshly allocated in @mkListGrds@ and @a@ is the match--- variable.-mkListGrds :: Id -> [(Id, GrdVec)] -> DsM GrdVec--- See Note [Order of guards matter] for why we need to intertwine guards--- on list elements.-mkListGrds a [] = pure [vanillaConGrd a nilDataCon []]-mkListGrds a ((x, head_grds):xs) = do- b <- mkPmId (idType a)- tail_grds <- mkListGrds b xs- pure $ vanillaConGrd a consDataCon [x, b] : head_grds ++ tail_grds---- | Create a 'GrdVec' refining a match variable to a 'PmLit'.-mkPmLitGrds :: Id -> PmLit -> DsM GrdVec-mkPmLitGrds x (PmLit _ (PmLitString s)) = do- -- We translate String literals to list literals for better overlap reasoning.- -- It's a little unfortunate we do this here rather than in- -- 'GHC.HsToCore.PmCheck.Oracle.trySolve' and- -- 'GHC.HsToCore.PmCheck.Oracle.addRefutableAltCon', but it's so much simpler- -- here. See Note [Representation of Strings in TmState] in- -- GHC.HsToCore.PmCheck.Oracle- vars <- traverse mkPmId (take (lengthFS s) (repeat charTy))- let mk_char_lit y c = mkPmLitGrds y (PmLit charTy (PmLitChar c))- char_grdss <- zipWithM mk_char_lit vars (unpackFS s)- mkListGrds x (zip vars char_grdss)-mkPmLitGrds x lit = do- let grd = PmCon { pm_id = x- , pm_con_con = PmAltLit lit- , pm_con_tvs = []- , pm_con_dicts = []- , pm_con_args = [] }- pure [grd]---- -------------------------------------------------------------------------- * Transform (Pat Id) into GrdVec---- | @translatePat _ x pat@ transforms @pat@ into a 'GrdVec', where--- the variable representing the match is @x@.-translatePat :: FamInstEnvs -> Id -> Pat GhcTc -> DsM GrdVec-translatePat fam_insts x pat = case pat of- WildPat _ty -> pure []- VarPat _ y -> pure (mkPmLetVar (unLoc y) x)- ParPat _ p -> translateLPat fam_insts x p- LazyPat _ _ -> pure [] -- like a wildcard- BangPat _ p@(L l p') ->- -- Add the bang in front of the list, because it will happen before any- -- nested stuff.- (PmBang x pm_loc :) <$> translateLPat fam_insts x p- where pm_loc = Just (L l (ppr p'))-- -- (x@pat) ==> Translate pat with x as match var and handle impedance- -- mismatch with incoming match var- AsPat _ (L _ y) p -> (mkPmLetVar y x ++) <$> translateLPat fam_insts y p-- SigPat _ p _ty -> translateLPat fam_insts x p-- -- See Note [Translate CoPats]- -- Generally the translation is- -- pat |> co ===> let y = x |> co, pat <- y where y is a match var of pat- XPat (CoPat wrapper p _ty)- | isIdHsWrapper wrapper -> translatePat fam_insts x p- | WpCast co <- wrapper, isReflexiveCo co -> translatePat fam_insts x p- | otherwise -> do- (y, grds) <- translatePatV fam_insts p- wrap_rhs_y <- dsHsWrapper wrapper- pure (PmLet y (wrap_rhs_y (Var x)) : grds)-- -- (n + k) ===> let b = x >= k, True <- b, let n = x-k- NPlusKPat _pat_ty (L _ n) k1 k2 ge minus -> do- b <- mkPmId boolTy- let grd_b = vanillaConGrd b trueDataCon []- [ke1, ke2] <- traverse dsOverLit [unLoc k1, k2]- rhs_b <- dsSyntaxExpr ge [Var x, ke1]- rhs_n <- dsSyntaxExpr minus [Var x, ke2]- pure [PmLet b rhs_b, grd_b, PmLet n rhs_n]-- -- (fun -> pat) ===> let y = fun x, pat <- y where y is a match var of pat- ViewPat _arg_ty lexpr pat -> do- (y, grds) <- translateLPatV fam_insts pat- fun <- dsLExpr lexpr- pure $ PmLet y (App fun (Var x)) : grds-- -- list- ListPat (ListPatTc _elem_ty Nothing) ps ->- translateListPat fam_insts x ps-- -- overloaded list- ListPat (ListPatTc elem_ty (Just (pat_ty, to_list))) pats -> do- dflags <- getDynFlags- case splitListTyConApp_maybe pat_ty of- Just _e_ty- | not (xopt LangExt.RebindableSyntax dflags)- -- Just translate it as a regular ListPat- -> translateListPat fam_insts x pats- _ -> do- y <- mkPmId (mkListTy elem_ty)- grds <- translateListPat fam_insts y pats- rhs_y <- dsSyntaxExpr to_list [Var x]- pure $ PmLet y rhs_y : grds-- -- (a) In the presence of RebindableSyntax, we don't know anything about- -- `toList`, we should treat `ListPat` as any other view pattern.- --- -- (b) In the absence of RebindableSyntax,- -- - If the pat_ty is `[a]`, then we treat the overloaded list pattern- -- as ordinary list pattern. Although we can give an instance- -- `IsList [Int]` (more specific than the default `IsList [a]`), in- -- practice, we almost never do that. We assume the `to_list` is- -- the `toList` from `instance IsList [a]`.- --- -- - Otherwise, we treat the `ListPat` as ordinary view pattern.- --- -- See #14547, especially comment#9 and comment#10.-- ConPat { pat_con = L _ con- , pat_args = ps- , pat_con_ext = ConPatTc- { cpt_arg_tys = arg_tys- , cpt_tvs = ex_tvs- , cpt_dicts = dicts- }- } -> do- translateConPatOut fam_insts x con arg_tys ex_tvs dicts ps-- NPat ty (L _ olit) mb_neg _ -> do- -- See Note [Literal short cut] in "GHC.HsToCore.Match.Literal"- -- We inline the Literal short cut for @ty@ here, because @ty@ is more- -- precise than the field of OverLitTc, which is all that dsOverLit (which- -- normally does the literal short cut) can look at. Also @ty@ matches the- -- type of the scrutinee, so info on both pattern and scrutinee (for which- -- short cutting in dsOverLit works properly) is overloaded iff either is.- dflags <- getDynFlags- let platform = targetPlatform dflags- core_expr <- case olit of- OverLit{ ol_val = val, ol_ext = OverLitTc rebindable _ }- | not rebindable- , Just expr <- shortCutLit platform val ty- -> dsExpr expr- _ -> dsOverLit olit- let lit = expectJust "failed to detect OverLit" (coreExprAsPmLit core_expr)- let lit' = case mb_neg of- Just _ -> expectJust "failed to negate lit" (negatePmLit lit)- Nothing -> lit- mkPmLitGrds x lit'-- LitPat _ lit -> do- core_expr <- dsLit (convertLit lit)- let lit = expectJust "failed to detect Lit" (coreExprAsPmLit core_expr)- mkPmLitGrds x lit-- TuplePat _tys pats boxity -> do- (vars, grdss) <- mapAndUnzipM (translateLPatV fam_insts) pats- let tuple_con = tupleDataCon boxity (length vars)- pure $ vanillaConGrd x tuple_con vars : concat grdss-- SumPat _ty p alt arity -> do- (y, grds) <- translateLPatV fam_insts p- let sum_con = sumDataCon alt arity- -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon- pure $ vanillaConGrd x sum_con [y] : grds-- -- --------------------------------------------------------------------------- -- Not supposed to happen- SplicePat {} -> panic "Check.translatePat: SplicePat"---- | 'translatePat', but also select and return a new match var.-translatePatV :: FamInstEnvs -> Pat GhcTc -> DsM (Id, GrdVec)-translatePatV fam_insts pat = do- x <- selectMatchVar Many pat- grds <- translatePat fam_insts x pat- pure (x, grds)--translateLPat :: FamInstEnvs -> Id -> LPat GhcTc -> DsM GrdVec-translateLPat fam_insts x = translatePat fam_insts x . unLoc---- | 'translateLPat', but also select and return a new match var.-translateLPatV :: FamInstEnvs -> LPat GhcTc -> DsM (Id, GrdVec)-translateLPatV fam_insts = translatePatV fam_insts . unLoc---- | @translateListPat _ x [p1, ..., pn]@ is basically--- @translateConPatOut _ x $(mkListConPatOuts [p1, ..., pn]>@ without ever--- constructing the 'ConPatOut's.-translateListPat :: FamInstEnvs -> Id -> [LPat GhcTc] -> DsM GrdVec-translateListPat fam_insts x pats = do- vars_and_grdss <- traverse (translateLPatV fam_insts) pats- mkListGrds x vars_and_grdss---- | Translate a constructor pattern-translateConPatOut :: FamInstEnvs -> Id -> ConLike -> [Type] -> [TyVar]- -> [EvVar] -> HsConPatDetails GhcTc -> DsM GrdVec-translateConPatOut fam_insts x con univ_tys ex_tvs dicts = \case- PrefixCon ps -> go_field_pats (zip [0..] ps)- InfixCon p1 p2 -> go_field_pats (zip [0..] [p1,p2])- RecCon (HsRecFields fs _) -> go_field_pats (rec_field_ps fs)- where- -- The actual argument types (instantiated)- arg_tys = map scaledThing $ conLikeInstOrigArgTys con (univ_tys ++ mkTyVarTys ex_tvs)-- -- Extract record field patterns tagged by field index from a list of- -- LHsRecField- rec_field_ps fs = map (tagged_pat . unLoc) fs- where- tagged_pat f = (lbl_to_index (getName (hsRecFieldId f)), hsRecFieldArg f)- -- Unfortunately the label info is empty when the DataCon wasn't defined- -- with record field labels, hence we translate to field index.- orig_lbls = map flSelector $ conLikeFieldLabels con- lbl_to_index lbl = expectJust "lbl_to_index" $ elemIndex lbl orig_lbls-- go_field_pats tagged_pats = do- -- The fields that appear might not be in the correct order. So first- -- do a PmCon match, then force according to field strictness and then- -- force evaluation of the field patterns in the order given by- -- the first field of @tagged_pats@.- -- See Note [Field match order for RecCon]-- -- Translate the mentioned field patterns. We're doing this first to get- -- the Ids for pm_con_args.- let trans_pat (n, pat) = do- (var, pvec) <- translateLPatV fam_insts pat- pure ((n, var), pvec)- (tagged_vars, arg_grdss) <- mapAndUnzipM trans_pat tagged_pats-- let get_pat_id n ty = case lookup n tagged_vars of- Just var -> pure var- Nothing -> mkPmId ty-- -- 1. the constructor pattern match itself- arg_ids <- zipWithM get_pat_id [0..] arg_tys- let con_grd = PmCon x (PmAltConLike con) ex_tvs dicts arg_ids-- -- 2. bang strict fields- let arg_is_banged = map isBanged $ conLikeImplBangs con- noSrcPmBang i = PmBang {pm_id = i, pm_loc = Nothing}- bang_grds = map noSrcPmBang (filterByList arg_is_banged arg_ids)-- -- 3. guards from field selector patterns- let arg_grds = concat arg_grdss-- -- tracePm "ConPatOut" (ppr x $$ ppr con $$ ppr arg_ids)- --- -- Store the guards in exactly that order- -- 1. 2. 3.- pure (con_grd : bang_grds ++ arg_grds)---- | Translate a the 'Match'es of a 'MatchGroup'-translateMatches :: FamInstEnvs -> [Id] -> [LMatch GhcTc (LHsExpr GhcTc)]- -> DsM GrdTree-translateMatches fam_insts vars matches =- -- It's important that we wrap a 'Sequence' even if it only wraps a singleton.- -- 'extractRhsDeltas' needs this to recover 'MatchGroup' structure.- Sequence <$> traverse (translateMatch fam_insts vars) matches---- Translate a single match-translateMatch :: FamInstEnvs -> [Id] -> LMatch GhcTc (LHsExpr GhcTc)- -> DsM GrdTree-translateMatch fam_insts vars (L match_loc (Match { m_pats = pats, m_grhss = grhss })) = do- pats' <- concat <$> zipWithM (translateLPat fam_insts) vars pats- grhss' <- translateGRHSs fam_insts match_loc (sep (map ppr pats)) grhss- -- tracePm "translateMatch" (vcat [ppr pats, ppr pats', ppr grhss'])- return (foldr Guard grhss' pats')--mkGrdTreeRhs :: Located SDoc -> GrdVec -> GrdTree-mkGrdTreeRhs sdoc = foldr Guard (Rhs sdoc)--translateGRHSs :: FamInstEnvs -> SrcSpan -> SDoc -> GRHSs GhcTc (LHsExpr GhcTc) -> DsM GrdTree-translateGRHSs fam_insts match_loc pp_pats grhss =- -- It's important that we wrap a 'Sequence' even if it only wraps a singleton.- -- 'extractRhsDeltas' needs this to recover 'GRHSs' structure.- Sequence <$> traverse (translateLGRHS fam_insts match_loc pp_pats) (grhssGRHSs grhss)---- | Translate a guarded right-hand side to a single 'GrdTree'-translateLGRHS :: FamInstEnvs -> SrcSpan -> SDoc -> LGRHS GhcTc (LHsExpr GhcTc) -> DsM GrdTree-translateLGRHS fam_insts match_loc pp_pats (L _loc (GRHS _ gs _)) =- -- _loc points to the match separator (ie =, ->) that comes after the guards..- mkGrdTreeRhs loc_sdoc <$> concatMapM (translateGuard fam_insts . unLoc) gs- where- loc_sdoc- -- pp_pats is the space-separated pattern of the current Match this- -- GRHS belongs to, so the @A B x@ part in @A B x | 0 <- x@.- | null gs = L match_loc pp_pats- | otherwise = L grd_loc (pp_pats <+> vbar <+> interpp'SP gs)- L grd_loc _ = head gs---- | Translate a guard statement to a 'GrdVec'-translateGuard :: FamInstEnvs -> GuardStmt GhcTc -> DsM GrdVec-translateGuard fam_insts guard = case guard of- BodyStmt _ e _ _ -> translateBoolGuard e- LetStmt _ binds -> translateLet (unLoc binds)- BindStmt _ p e -> translateBind fam_insts p e- LastStmt {} -> panic "translateGuard LastStmt"- ParStmt {} -> panic "translateGuard ParStmt"- TransStmt {} -> panic "translateGuard TransStmt"- RecStmt {} -> panic "translateGuard RecStmt"- ApplicativeStmt {} -> panic "translateGuard ApplicativeLastStmt"---- | Translate let-bindings-translateLet :: HsLocalBinds GhcTc -> DsM GrdVec-translateLet _binds = return []---- | Translate a pattern guard--- @pat <- e ==> let x = e; <guards for pat <- x>@-translateBind :: FamInstEnvs -> LPat GhcTc -> LHsExpr GhcTc -> DsM GrdVec-translateBind fam_insts p e = dsLExpr e >>= \case- Var y- | Nothing <- isDataConId_maybe y- -- RHS is a variable, so that will allow us to omit the let- -> translateLPat fam_insts y p- rhs -> do- (x, grds) <- translateLPatV fam_insts p- pure (PmLet x rhs : grds)---- | Translate a boolean guard--- @e ==> let x = e; True <- x@-translateBoolGuard :: LHsExpr GhcTc -> DsM GrdVec-translateBoolGuard e- | isJust (isTrueLHsExpr e) = return []- -- The formal thing to do would be to generate (True <- True)- -- but it is trivial to solve so instead we give back an empty- -- GrdVec for efficiency- | otherwise = dsLExpr e >>= \case- Var y- | Nothing <- isDataConId_maybe y- -- Omit the let by matching on y- -> pure [vanillaConGrd y trueDataCon []]- rhs -> do- x <- mkPmId boolTy- pure $ [PmLet x rhs, vanillaConGrd x trueDataCon []]--{- Note [Field match order for RecCon]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The order for RecCon field patterns actually determines evaluation order of-the pattern match. For example:-- data T = T { a :: !Bool, b :: Char, c :: Int }- f :: T -> ()- f T{ c = 42, b = 'b' } = ()--Then- * @f (T (error "a") (error "b") (error "c"))@ errors out with "a" because of- the strict field.- * @f (T True (error "b") (error "c"))@ errors out with "c" because it- is mentioned frist in the pattern match.--This means we can't just desugar the pattern match to the PatVec-@[T !_ 'b' 42]@. Instead we have to generate variable matches that have-strictness according to the field declarations and afterwards force them in the-right order. As a result, we get the PatVec @[T !_ b c, 42 <- c, 'b' <- b]@.--Of course, when the labels occur in the order they are defined, we can just use-the simpler desugaring.--Note [Order of guards matters]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Similar to Note [Field match order for RecCon], the order in which the guards-for a pattern match appear matter. Consider a situation similar to T5117:-- f (0:_) = ()- f (0:[]) = ()--The latter clause is clearly redundant. Yet if we translate the second clause as-- [x:xs' <- xs, [] <- xs', 0 <- x]--We will say that the second clause only has an inaccessible RHS. That's because-we force the tail of the list before comparing its head! So the correct-translation would have been-- [x:xs' <- xs, 0 <- x, [] <- xs']--And we have to take in the guards on list cells into @mkListGrds@.--Note [Countering exponential blowup]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Precise pattern match exhaustiveness checking is necessarily exponential in-the size of some input programs. We implement a counter-measure in the form of-the -fmax-pmcheck-models flag, limiting the number of Deltas we check against-each pattern by a constant.--How do we do that? Consider-- f True True = ()- f True True = ()--And imagine we set our limit to 1 for the sake of the example. The first clause-will be checked against the initial Delta, {}. Doing so will produce an-Uncovered set of size 2, containing the models {x/~True} and {x~True,y/~True}.-Also we find the first clause to cover the model {x~True,y~True}.--But the Uncovered set we get out of the match is too huge! We somehow have to-ensure not to make things worse as they are already, so we continue checking-with a singleton Uncovered set of the initial Delta {}. Why is this-sound (wrt. notion of the GADTs Meet their Match paper)? Well, it basically-amounts to forgetting that we matched against the first clause. The values-represented by {} are a superset of those represented by its two refinements-{x/~True} and {x~True,y/~True}.--This forgetfulness becomes very apparent in the example above: By continuing-with {} we don't detect the second clause as redundant, as it again covers the-same non-empty subset of {}. So we don't flag everything as redundant anymore,-but still will never flag something as redundant that isn't.--For exhaustivity, the converse applies: We will report @f@ as non-exhaustive-and report @f _ _@ as missing, which is a superset of the actual missing-matches. But soundness means we will never fail to report a missing match.--This mechanism is implemented in 'throttle'.--Guards are an extreme example in this regard, with #11195 being a particularly-dreadful example: Since their RHS are often pretty much unique, we split on a-variable (the one representing the RHS) that doesn't occur anywhere else in the-program, so we don't actually get useful information out of that split!--Note [Translate CoPats]-~~~~~~~~~~~~~~~~~~~~~~~-The pattern match checker did not know how to handle coerced patterns `CoPat`-efficiently, which gave rise to #11276. The original approach translated-`CoPat`s:-- pat |> co ===> x (pat <- (x |> co))--Why did we do this seemingly unnecessary expansion in the first place?-The reason is that the type of @pat |> co@ (which is the type of the value-abstraction we match against) might be different than that of @pat@. Data-instances such as @Sing (a :: Bool)@ are a good example of this: If we would-just drop the coercion, we'd get a type error when matching @pat@ against its-value abstraction, with the result being that pmIsSatisfiable decides that every-possible data constructor fitting @pat@ is rejected as uninhabitated, leading to-a lot of false warnings.--But we can check whether the coercion is a hole or if it is just refl, in-which case we can drop it.--%************************************************************************-%* *- Utilities for Pattern Match Checking-%* *-%************************************************************************--}---- ------------------------------------------------------------------------------- * Basic utilities--{--Note [Extensions to GADTs Meet Their Match]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The GADTs Meet Their Match paper presents the formalism that GHC's coverage-checker adheres to. Since the paper's publication, there have been some-additional features added to the coverage checker which are not described in-the paper. This Note serves as a reference for these new features.--* Value abstractions are severely simplified to the point where they are just- variables. The information about the shape of a variable is encoded in- the oracle state 'Delta' instead.-* Handling of uninhabited fields like `!Void`.- See Note [Strict argument type constraints] in GHC.HsToCore.PmCheck.Oracle.-* Efficient handling of literal splitting, large enumerations and accurate- redundancy warnings for `COMPLETE` groups through the oracle.--Note [Filtering out non-matching COMPLETE sets]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Currently, conlikes in a COMPLETE set are simply grouped by the-type constructor heading the return type. This is nice and simple, but it does-mean that there are scenarios when a COMPLETE set might be incompatible with-the type of a scrutinee. For instance, consider (from #14135):-- data Foo a = Foo1 a | Foo2 a-- pattern MyFoo2 :: Int -> Foo Int- pattern MyFoo2 i = Foo2 i-- {-# COMPLETE Foo1, MyFoo2 #-}-- f :: Foo a -> a- f (Foo1 x) = x--`f` has an incomplete pattern-match, so when choosing which constructors to-report as unmatched in a warning, GHC must choose between the original set of-data constructors {Foo1, Foo2} and the COMPLETE set {Foo1, MyFoo2}. But observe-that GHC shouldn't even consider the COMPLETE set as a possibility: the return-type of MyFoo2, Foo Int, does not match the type of the scrutinee, Foo a, since-there's no substitution `s` such that s(Foo Int) = Foo a.--To ensure that GHC doesn't pick this COMPLETE set, it checks each pattern-synonym constructor's return type matches the type of the scrutinee, and if one-doesn't, then we remove the whole COMPLETE set from consideration.--One might wonder why GHC only checks /pattern synonym/ constructors, and not-/data/ constructors as well. The reason is because that the type of a-GADT constructor very well may not match the type of a scrutinee, and that's-OK. Consider this example (from #14059):-- data SBool (z :: Bool) where- SFalse :: SBool False- STrue :: SBool True-- pattern STooGoodToBeTrue :: forall (z :: Bool). ()- => z ~ True- => SBool z- pattern STooGoodToBeTrue = STrue- {-# COMPLETE SFalse, STooGoodToBeTrue #-}-- wobble :: SBool z -> Bool- wobble STooGoodToBeTrue = True--In the incomplete pattern match for `wobble`, we /do/ want to warn that SFalse-should be matched against, even though its type, SBool False, does not match-the scrutinee type, SBool z.--SG: Another angle at this is that the implied constraints when we instantiate-universal type variables in the return type of a GADT will lead to *provided*-thetas, whereas when we instantiate the return type of a pattern synonym that-corresponds to a *required* theta. See Note [Pattern synonym result type] in-PatSyn. Note how isValidCompleteMatches will successfully filter out-- pattern Just42 :: Maybe Int- pattern Just42 = Just 42--But fail to filter out the equivalent-- pattern Just'42 :: (a ~ Int) => Maybe a- pattern Just'42 = Just 42--Which seems fine as far as tcMatchTy is concerned, but it raises a few eye-brows.--}--{--%************************************************************************-%* *- Heart of the algorithm: checkGrdTree-%* *-%************************************************************************--}---- | @throttle limit old new@ returns @old@ if the number of 'Delta's in @new@--- is exceeding the given @limit@ and the @old@ number of 'Delta's.--- See Note [Countering exponential blowup].-throttle :: Int -> Deltas -> Deltas -> (Precision, Deltas)-throttle limit old@(MkDeltas old_ds) new@(MkDeltas new_ds)- --- | pprTrace "PmCheck:throttle" (ppr (length old_ds) <+> ppr (length new_ds) <+> ppr limit) False = undefined- | length new_ds > max limit (length old_ds) = (Approximate, old)- | otherwise = (Precise, new)---- | Matching on a newtype doesn't force anything.--- See Note [Divergence of Newtype matches] in "GHC.HsToCore.PmCheck.Oracle".-conMatchForces :: PmAltCon -> Bool-conMatchForces (PmAltConLike (RealDataCon dc))- | isNewTyCon (dataConTyCon dc) = False-conMatchForces _ = True---- | Makes sure that we only wrap a single 'MayDiverge' around an--- 'AnnotatedTree', purely for esthetic reasons.-mayDiverge :: AnnotatedTree -> AnnotatedTree-mayDiverge a@(MayDiverge _) = a-mayDiverge a = MayDiverge a---- | Computes two things:------ * The set of uncovered values not matched by any of the clauses of the--- 'GrdTree'. Note that 'PmCon' guards are the only way in which values--- fall through from one 'Many' branch to the next.--- * An 'AnnotatedTree' that contains divergence and inaccessibility info--- for all clauses. Will be fed to 'extractRedundancyInfo' for--- presenting redundant and proper innaccessible RHSs, as well as dead--- bangs to the user.-checkGrdTree' :: GrdTree -> Deltas -> DsM CheckResult--- RHS: Check that it covers something and wrap Inaccessible if not-checkGrdTree' (Rhs sdoc) deltas = do- is_covered <- isInhabited deltas- let clauses- | is_covered = AccessibleRhs deltas sdoc- | otherwise = InaccessibleRhs sdoc- pure CheckResult- { cr_clauses = clauses- , cr_uncov = MkDeltas emptyBag- , cr_approx = Precise }--- let x = e: Refine with x ~ e-checkGrdTree' (Guard (PmLet x e) tree) deltas = do- deltas' <- addPmCtDeltas deltas (PmCoreCt x e)- checkGrdTree' tree deltas'--- Bang x: Diverge on x ~ ⊥, refine with x /~ ⊥-checkGrdTree' (Guard (PmBang x src_bang_info) tree) deltas = do- has_diverged <- addPmCtDeltas deltas (PmBotCt x) >>= isInhabited- deltas' <- addPmCtDeltas deltas (PmNotBotCt x)- res <- checkGrdTree' tree deltas'- let clauses- | not has_diverged- , Just info <- src_bang_info- = RedundantSrcBang info (cr_clauses res)- | has_diverged- = mayDiverge (cr_clauses res)- | otherwise -- won't diverge and it wasn't a source bang- = cr_clauses res-- pure res{ cr_clauses = clauses }---- Con: Diverge on x ~ ⊥, fall through on x /~ K and refine with x ~ K ys--- and type info-checkGrdTree' (Guard (PmCon x con tvs dicts args) tree) deltas = do- has_diverged <-- if conMatchForces con- then addPmCtDeltas deltas (PmBotCt x) >>= isInhabited- else pure False- unc_this <- addPmCtDeltas deltas (PmNotConCt x con)- deltas' <- addPmCtsDeltas deltas $- listToBag (PmTyCt . evVarPred <$> dicts) `snocBag` PmConCt x con tvs args- -- tracePm "checkGrdTree:Con" (ppr deltas $$ ppr x $$ ppr con $$ ppr dicts $$ ppr deltas')- CheckResult tree' unc_inner prec <- checkGrdTree' tree deltas'- limit <- maxPmCheckModels <$> getDynFlags- let (prec', unc') = throttle limit deltas (unc_this Semi.<> unc_inner)- pure CheckResult- { cr_clauses = applyWhen has_diverged mayDiverge tree'- , cr_uncov = unc'- , cr_approx = prec Semi.<> prec' }--- Sequence: Thread residual uncovered sets from equation to equation-checkGrdTree' (Sequence ts) init_unc = go [] init_unc Precise ts- where- -- | Accumulates a CheckResult. Its type is more like- -- @CheckResult -> [GrdTree] -> CheckResult@, but cr_clauses is a single- -- 'AnnotatedTree', not a list thereof. Hence 3 parameters to thread the- -- fields.- go :: [AnnotatedTree] -> Deltas -> Precision -> [GrdTree] -> DsM CheckResult- -- No cases left: Fall through for all values- go ts' unc prec [] = pure CheckResult- { cr_clauses = SequenceAnn init_unc (reverse ts')- , cr_uncov = unc- , cr_approx = prec }- go ts' unc prec (t:ts) = do- CheckResult t' unc_1 prec_t <- checkGrdTree' t unc- go (t':ts') unc_1 (prec_t Semi.<> prec) ts---- | Print diagnostic info and actually call 'checkGrdTree''.-checkGrdTree :: GrdTree -> Deltas -> DsM CheckResult-checkGrdTree guards deltas = do- tracePm "checkGrdTree {" $ vcat [ ppr guards- , ppr deltas ]- res <- checkGrdTree' guards deltas- tracePm "checkGrdTree }:" (ppr res) -- braces are easier to match by tooling- return res---- ------------------------------------------------------------------------------- * Propagation of term constraints inwards when checking nested matches--{- Note [Type and Term Equality Propagation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When checking a match it would be great to have all type and term information-available so we can get more precise results. For this reason we have functions-`addDictsDs' and `addTmVarCsDs' in GHC.HsToCore.Monad that store in the-environment type and term constraints (respectively) as we go deeper.--The type constraints we propagate inwards are collected by `collectEvVarsPats'-in GHC.Hs.Pat. This handles bug #4139 ( see example- https://gitlab.haskell.org/ghc/ghc/snippets/672 )-where this is needed.--For term equalities we do less, we just generate equalities for HsCase. For-example we accurately give 2 redundancy warnings for the marked cases:--f :: [a] -> Bool-f x = case x of-- [] -> case x of -- brings (x ~ []) in scope- [] -> True- (_:_) -> False -- can't happen-- (_:_) -> case x of -- brings (x ~ (_:_)) in scope- (_:_) -> True- [] -> False -- can't happen--Functions `addScrutTmCs' is responsible for generating-these constraints.--}---- | Locally update 'dsl_deltas' with the given action, but defer evaluation--- with 'unsafeInterleaveM' in order not to do unnecessary work.-locallyExtendPmDelta :: (Deltas -> DsM Deltas) -> DsM a -> DsM a-locallyExtendPmDelta ext k = do- deltas <- getPmDeltas- deltas' <- unsafeInterleaveM $ do- deltas' <- ext deltas- inh <- isInhabited deltas'- -- If adding a constraint would lead to a contradiction, don't add it.- -- See @Note [Recovering from unsatisfiable pattern-matching constraints]@- -- for why this is done.- if inh- then pure deltas'- else pure deltas- updPmDeltas deltas' k---- | Add in-scope type constraints if the coverage checker might run and then--- run the given action.-addTyCsDs :: Origin -> Bag EvVar -> DsM a -> DsM a-addTyCsDs origin ev_vars m = do- dflags <- getDynFlags- applyWhen (needToRunPmCheck dflags origin)- (locallyExtendPmDelta (\deltas -> addPmCtsDeltas deltas (PmTyCt . evVarPred <$> ev_vars)))- m---- | Add equalities for the scrutinee to the local 'DsM' environment when--- checking a case expression:--- case e of x { matches }--- When checking matches we record that (x ~ e) where x is the initial--- uncovered. All matches will have to satisfy this equality.-addScrutTmCs :: Maybe (LHsExpr GhcTc) -> [Id] -> DsM a -> DsM a-addScrutTmCs Nothing _ k = k-addScrutTmCs (Just scr) [x] k = do- scr_e <- dsLExpr scr- locallyExtendPmDelta (\deltas -> addPmCtsDeltas deltas (unitBag (PmCoreCt x scr_e))) k-addScrutTmCs _ _ _ = panic "addScrutTmCs: HsCase with more than one case binder"--{--%************************************************************************-%* *- Pretty printing of exhaustiveness/redundancy check warnings-%* *-%************************************************************************--}---- | Check whether any part of pattern match checking is enabled for this--- 'HsMatchContext' (does not matter whether it is the redundancy check or the--- exhaustiveness check).-isMatchContextPmChecked :: DynFlags -> Origin -> HsMatchContext id -> Bool-isMatchContextPmChecked dflags origin kind- | isGenerated origin- = False- | otherwise- = wopt Opt_WarnOverlappingPatterns dflags || exhaustive dflags kind---- | Return True when any of the pattern match warnings ('allPmCheckWarnings')--- are enabled, in which case we need to run the pattern match checker.-needToRunPmCheck :: DynFlags -> Origin -> Bool-needToRunPmCheck dflags origin- | isGenerated origin- = False- | otherwise- = notNull (filter (`wopt` dflags) allPmCheckWarnings)---- | A type for organising information to be used in warnings.-data RedundancyInfo- = RedundancyInfo- { redundant_rhss :: ![SrcInfo]- , inaccessible_rhss :: ![SrcInfo]- , redundant_bangs :: ![Located SDoc]- }--extractRedundancyInfo :: AnnotatedTree -> RedundancyInfo-extractRedundancyInfo tree =- RedundancyInfo { redundant_rhss = fromOL ol_red- , inaccessible_rhss = fromOL ol_inacc- , redundant_bangs = fromOL ol_bangs }- where- (_ol_acc, ol_inacc, ol_red, ol_bangs) = go tree- -- | Collects- -- 1. accessible RHSs- -- 2. proper inaccessible RHSs (so we can't delete them)- -- 3. hypothetically redundant RHSs (so not only inaccessible, but we can- -- even safely delete the equation without altering semantics)- -- 4. 'Dead' bangs from the source, collected to be warned about- -- See Note [Determining inaccessible clauses]- -- See Note [Dead bang patterns]- go :: AnnotatedTree -> (OrdList SrcInfo, OrdList SrcInfo, OrdList SrcInfo, OrdList SrcInfo)- go (AccessibleRhs _ info) = (unitOL info, nilOL, nilOL , nilOL)- go (InaccessibleRhs info) = (nilOL, nilOL, unitOL info, nilOL) -- presumably redundant- go (MayDiverge t) = case go t of- -- See Note [Determining inaccessible clauses]- (acc, inacc, red, bs)- | isNilOL acc && isNilOL inacc -> (nilOL, red, nilOL, bs)- res -> res- go (SequenceAnn _ ts) = foldMap go ts- go (RedundantSrcBang l t) = case go t of- -- See Note [Dead bang patterns]- res@(acc, inacc, _, _)- | isNilOL acc, isNilOL inacc -> res- | otherwise -> (nilOL, nilOL, nilOL, unitOL l) Semi.<> res--{- Note [Determining inaccessible clauses]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider- f _ True = ()- f () True = ()- f _ _ = ()-Is f's second clause redundant? The perhaps surprising answer is, no, it isn't!-@f (error "boom") False@ will force the error with clause 2, but will return-() if it was deleted, so clearly not redundant. Yet for now combination of-arguments we can ever reach clause 2's RHS, so we say it has inaccessible RHS-(as opposed to being completely redundant).--We detect an inaccessible RHS simply by pretending it's redundant, until we see-that it's part of a sub-tree in the pattern match that forces some argument-(which corresponds to wrapping the 'AnnotatedTree' in 'MayDiverge'). Then we-turn all supposedly redundant RHSs into inaccessible ones.--But as it turns out (@g@ from #17465) this is too conservative:- g () | False = ()- | otherwise = ()-g's first clause has an inaccessible RHS, but it's also safe to delete. So it's-redundant, really! But by just turning all redundant child clauses into-inaccessible ones, we report the first clause as inaccessible.--Clearly, it is enough if we say that we only degrade if *not all* of the child-clauses are redundant. As long as there is at least one clause which we announce-not to be redundant, the guard prefix responsible for the 'MayDiverge' will-survive. Hence we check for that in 'extractRedundancyInfo'.--}---- | Issue all the warnings (coverage, exhaustiveness, inaccessibility)-dsPmWarn :: DynFlags -> DsMatchContext -> [Id] -> CheckResult -> DsM ()-dsPmWarn dflags ctx@(DsMatchContext kind loc) vars result- = when (flag_i || flag_u || flag_b) $ do- unc_examples <- getNFirstUncovered vars (maxPatterns + 1) uncovered- let exists_r = flag_i && notNull redundant_rhss- exists_i = flag_i && notNull inaccessible_rhss- exists_u = flag_u && notNull unc_examples- exists_b = flag_b && notNull redundant_bangs- approx = precision == Approximate-- when (approx && (exists_u || exists_i)) $- putSrcSpanDs loc (warnDs NoReason approx_msg)-- when exists_b $ forM_ redundant_bangs $ \(L l q) -> do- putSrcSpanDs l (warnDs (Reason Opt_WarnRedundantBangPatterns)- (pprEqn q "has redundant bang"))-- when exists_r $ forM_ redundant_rhss $ \(L l q) -> do- putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)- (pprEqn q "is redundant"))- when exists_i $ forM_ inaccessible_rhss $ \(L l q) -> do- putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)- (pprEqn q "has inaccessible right hand side"))-- when exists_u $ putSrcSpanDs loc $ warnDs flag_u_reason $- pprEqns vars unc_examples- where- CheckResult- { cr_clauses = clauses- , cr_uncov = uncovered- , cr_approx = precision } = result- RedundancyInfo{redundant_rhss, inaccessible_rhss, redundant_bangs}- = extractRedundancyInfo clauses-- flag_i = overlapping dflags kind- flag_u = exhaustive dflags kind- flag_b = redundant_bang dflags- flag_u_reason = maybe NoReason Reason (exhaustiveWarningFlag kind)-- maxPatterns = maxUncoveredPatterns dflags-- -- Print a single clause (for redundant/with-inaccessible-rhs)- pprEqn q txt = pprContext True ctx (text txt) $ \f ->- f (q <+> matchSeparator kind <+> text "...")-- -- Print several clauses (for uncovered clauses)- pprEqns vars deltas = pprContext False ctx (text "are non-exhaustive") $ \_ ->- case vars of -- See #11245- [] -> text "Guards do not cover entire pattern space"- _ -> let us = map (\delta -> pprUncovered delta vars) deltas- in hang (text "Patterns not matched:") 4- (vcat (take maxPatterns us) $$ dots maxPatterns us)-- approx_msg = vcat- [ hang- (text "Pattern match checker ran into -fmax-pmcheck-models="- <> int (maxPmCheckModels dflags)- <> text " limit, so")- 2- ( bullet <+> text "Redundant clauses might not be reported at all"- $$ bullet <+> text "Redundant clauses might be reported as inaccessible"- $$ bullet <+> text "Patterns reported as unmatched might actually be matched")- , text "Increase the limit or resolve the warnings to suppress this message." ]--getNFirstUncovered :: [Id] -> Int -> Deltas -> DsM [Delta]-getNFirstUncovered vars n (MkDeltas deltas) = go n (bagToList deltas)- where- go 0 _ = pure []- go _ [] = pure []- go n (delta:deltas) = do- front <- provideEvidence vars n delta- back <- go (n - length front) deltas- pure (front ++ back)--{- Note [Inaccessible warnings for record updates]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider (#12957)- data T a where- T1 :: { x :: Int } -> T Bool- T2 :: { x :: Int } -> T a- T3 :: T a-- f :: T Char -> T a- f r = r { x = 3 }--The desugarer will (conservatively generate a case for T1 even though-it's impossible:- f r = case r of- T1 x -> T1 3 -- Inaccessible branch- T2 x -> T2 3- _ -> error "Missing"--We don't want to warn about the inaccessible branch because the programmer-didn't put it there! So we filter out the warning here.--The same can happen for long distance term constraints instead of type-constraints (#17783):-- data T = A { x :: Int } | B { x :: Int }- f r@A{} = r { x = 3 }- f _ = B 0--Here, the long distance info from the FunRhs match (@r ~ A x@) will make the-clause matching on @B@ of the desugaring to @case@ redundant. It's generated-code that we don't want to warn about.--}--dots :: Int -> [a] -> SDoc-dots maxPatterns qs- | qs `lengthExceeds` maxPatterns = text "..."- | otherwise = empty---- | All warning flags that need to run the pattern match checker.-allPmCheckWarnings :: [WarningFlag]-allPmCheckWarnings =- [ Opt_WarnIncompletePatterns- , Opt_WarnIncompleteUniPatterns- , Opt_WarnIncompletePatternsRecUpd- , Opt_WarnOverlappingPatterns- ]---- | Check whether the redundancy checker should run (redundancy only)-overlapping :: DynFlags -> HsMatchContext id -> Bool--- See Note [Inaccessible warnings for record updates]-overlapping _ RecUpd = False-overlapping dflags _ = wopt Opt_WarnOverlappingPatterns dflags---- | Check whether the exhaustiveness checker should run (exhaustiveness only)-exhaustive :: DynFlags -> HsMatchContext id -> Bool-exhaustive dflags = maybe False (`wopt` dflags) . exhaustiveWarningFlag---- | Check whether unnecessary bangs should be warned about-redundant_bang :: DynFlags -> Bool-redundant_bang dflags = wopt Opt_WarnRedundantBangPatterns dflags---- | Denotes whether an exhaustiveness check is supported, and if so,--- via which 'WarningFlag' it's controlled.--- Returns 'Nothing' if check is not supported.-exhaustiveWarningFlag :: HsMatchContext id -> Maybe WarningFlag-exhaustiveWarningFlag (FunRhs {}) = Just Opt_WarnIncompletePatterns-exhaustiveWarningFlag CaseAlt = Just Opt_WarnIncompletePatterns-exhaustiveWarningFlag IfAlt = Just Opt_WarnIncompletePatterns-exhaustiveWarningFlag LambdaExpr = Just Opt_WarnIncompleteUniPatterns-exhaustiveWarningFlag PatBindRhs = Just Opt_WarnIncompleteUniPatterns-exhaustiveWarningFlag PatBindGuards = Just Opt_WarnIncompletePatterns-exhaustiveWarningFlag ProcExpr = Just Opt_WarnIncompleteUniPatterns-exhaustiveWarningFlag RecUpd = Just Opt_WarnIncompletePatternsRecUpd-exhaustiveWarningFlag ThPatSplice = Nothing-exhaustiveWarningFlag PatSyn = Nothing-exhaustiveWarningFlag ThPatQuote = Nothing-exhaustiveWarningFlag (StmtCtxt {}) = Nothing -- Don't warn about incomplete patterns- -- in list comprehensions, pattern guards- -- etc. They are often *supposed* to be- -- incomplete---- True <==> singular-pprContext :: Bool -> DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc-pprContext singular (DsMatchContext kind _loc) msg rest_of_msg_fun- = vcat [text txt <+> msg,- sep [ text "In" <+> ppr_match <> char ':'- , nest 4 (rest_of_msg_fun pref)]]- where- txt | singular = "Pattern match"- | otherwise = "Pattern match(es)"-- (ppr_match, pref)- = case kind of- FunRhs { mc_fun = L _ fun }- -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)- _ -> (pprMatchContext kind, \ pp -> pp)
− compiler/GHC/HsToCore/PmCheck/Oracle.hs
@@ -1,1787 +0,0 @@-{--Authors: George Karachalias <george.karachalias@cs.kuleuven.be>- Sebastian Graf <sgraf1337@gmail.com>- Ryan Scott <ryan.gl.scott@gmail.com>--}--{-# LANGUAGE CPP, LambdaCase, TupleSections, PatternSynonyms, ViewPatterns, MultiWayIf #-}---- | The pattern match oracle. The main export of the module are the functions--- 'addPmCts' for adding facts to the oracle, and 'provideEvidence' to turn a--- 'Delta' into a concrete evidence for an equation.-module GHC.HsToCore.PmCheck.Oracle (-- DsM, tracePm, mkPmId,- Delta, initDeltas, lookupRefuts, lookupSolution,-- PmCt(PmTyCt), PmCts, pattern PmVarCt, pattern PmCoreCt,- pattern PmConCt, pattern PmNotConCt, pattern PmBotCt,- pattern PmNotBotCt,-- addPmCts, -- Add a constraint to the oracle.- canDiverge, -- Try to add the term equality x ~ ⊥- provideEvidence- ) where--#include "GhclibHsVersions.h"--import GHC.Prelude--import GHC.HsToCore.PmCheck.Types--import GHC.Driver.Session-import GHC.Utils.Outputable-import GHC.Utils.Error-import GHC.Utils.Misc-import GHC.Utils.Panic-import GHC.Data.Bag-import GHC.Types.Unique.Set-import GHC.Types.Unique.DSet-import GHC.Types.Unique-import GHC.Types.Id-import GHC.Types.Var.Env-import GHC.Types.Unique.DFM-import GHC.Types.Var (EvVar)-import GHC.Types.Name-import GHC.Core-import GHC.Core.FVs (exprFreeVars)-import GHC.Core.Map-import GHC.Core.SimpleOpt (simpleOptExpr, exprIsConApp_maybe)-import GHC.Core.Utils (exprType)-import GHC.Core.Make (mkListExpr, mkCharExpr)-import GHC.Types.Unique.Supply-import GHC.Data.FastString-import GHC.Types.SrcLoc-import GHC.Data.Maybe-import GHC.Core.ConLike-import GHC.Core.DataCon-import GHC.Core.PatSyn-import GHC.Core.TyCon-import GHC.Builtin.Types-import GHC.Builtin.Types.Prim (tYPETyCon)-import GHC.Core.TyCo.Rep-import GHC.Core.Type-import GHC.Tc.Solver (tcNormalise, tcCheckSatisfiability)-import GHC.Core.Unify (tcMatchTy)-import GHC.Tc.Types (completeMatchConLikes)-import GHC.Core.Coercion-import GHC.Utils.Monad hiding (foldlM)-import GHC.HsToCore.Monad hiding (foldlM)-import GHC.Tc.Instance.Family-import GHC.Core.FamInstEnv--import Control.Monad (guard, mzero, when)-import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.State.Strict-import Data.Bifunctor (second)-import Data.Either (partitionEithers)-import Data.Foldable (foldlM, minimumBy, toList)-import Data.List (find)-import qualified Data.List.NonEmpty as NonEmpty-import Data.Ord (comparing)-import qualified Data.Semigroup as Semigroup-import Data.Tuple (swap)---- Debugging Infrastructure--tracePm :: String -> SDoc -> DsM ()-tracePm herald doc = do- dflags <- getDynFlags- printer <- mkPrintUnqualifiedDs- liftIO $ dumpIfSet_dyn_printer printer dflags- Opt_D_dump_ec_trace "" FormatText (text herald $$ (nest 2 doc))-{-# INLINE tracePm #-} -- see Note [INLINE conditional tracing utilities]---- | Generate a fresh `Id` of a given type-mkPmId :: Type -> DsM Id-mkPmId ty = getUniqueM >>= \unique ->- let occname = mkVarOccFS $ fsLit "pm"- name = mkInternalName unique occname noSrcSpan- in return (mkLocalIdOrCoVar name Many ty)---------------------------------------------------- * Caching possible matches of a COMPLETE set--markMatched :: ConLike -> PossibleMatches -> PossibleMatches-markMatched _ NoPM = NoPM-markMatched con (PM ms) = PM (del_one_con con <$> ms)- where- del_one_con = flip delOneFromUniqDSet-------------------------------------------------------- * Instantiating constructors, types and evidence---- | Instantiate a 'ConLike' given its universal type arguments. Instantiates--- existential and term binders with fresh variables of appropriate type.--- Returns instantiated type and term variables from the match, type evidence--- and the types of strict constructor fields.-mkOneConFull :: [Type] -> ConLike -> DsM ([TyVar], [Id], Bag TyCt, [Type])--- * 'con' K is a ConLike--- - In the case of DataCons and most PatSynCons, these--- are associated with a particular TyCon T--- - But there are PatSynCons for this is not the case! See #11336, #17112------ * 'arg_tys' tys are the types K's universally quantified type--- variables should be instantiated to.--- - For DataCons and most PatSyns these are the arguments of their TyCon--- - For cases like the PatSyns in #11336, #17112, we can't easily guess--- these, so don't call this function.------ After instantiating the universal tyvars of K to tys we get--- K @tys :: forall bs. Q => s1 .. sn -> T tys--- Note that if K is a PatSynCon, depending on arg_tys, T might not necessarily--- be a concrete TyCon.------ Suppose y1 is a strict field. Then we get--- Results: bs--- [y1,..,yn]--- Q--- [s1]-mkOneConFull arg_tys con = do- let (univ_tvs, ex_tvs, eq_spec, thetas, _req_theta, field_tys, _con_res_ty)- = conLikeFullSig con- -- pprTrace "mkOneConFull" (ppr con $$ ppr arg_tys $$ ppr univ_tvs $$ ppr _con_res_ty) (return ())- -- Substitute universals for type arguments- let subst_univ = zipTvSubst univ_tvs arg_tys- -- Instantiate fresh existentials as arguments to the constructor. This is- -- important for instantiating the Thetas and field types.- (subst, _) <- cloneTyVarBndrs subst_univ ex_tvs <$> getUniqueSupplyM- let field_tys' = substTys subst $ map scaledThing field_tys- -- Instantiate fresh term variables (VAs) as arguments to the constructor- vars <- mapM mkPmId field_tys'- -- All constraints bound by the constructor (alpha-renamed), these are added- -- to the type oracle- let ty_cs = substTheta subst (eqSpecPreds eq_spec ++ thetas)- -- Figure out the types of strict constructor fields- let arg_is_strict- | RealDataCon dc <- con- , isNewTyCon (dataConTyCon dc)- = [True] -- See Note [Divergence of Newtype matches]- | otherwise- = map isBanged $ conLikeImplBangs con- strict_arg_tys = filterByList arg_is_strict field_tys'- return (ex_tvs, vars, listToBag ty_cs, strict_arg_tys)------------------------------ * Pattern match oracle---{- Note [Recovering from unsatisfiable pattern-matching constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider the following code (see #12957 and #15450):-- f :: Int ~ Bool => ()- f = case True of { False -> () }--We want to warn that the pattern-matching in `f` is non-exhaustive. But GHC-used not to do this; in fact, it would warn that the match was /redundant/!-This is because the constraint (Int ~ Bool) in `f` is unsatisfiable, and the-coverage checker deems any matches with unsatisfiable constraint sets to be-unreachable.--We decide to better than this. When beginning coverage checking, we first-check if the constraints in scope are unsatisfiable, and if so, we start-afresh with an empty set of constraints. This way, we'll get the warnings-that we expect.--}------------------------------------------ * Composable satisfiability checks---- | Given a 'Delta', check if it is compatible with new facts encoded in this--- this check. If so, return 'Just' a potentially extended 'Delta'. Return--- 'Nothing' if unsatisfiable.------ There are three essential SatisfiabilityChecks:--- 1. 'tmIsSatisfiable', adding term oracle facts--- 2. 'tyIsSatisfiable', adding type oracle facts--- 3. 'tysAreNonVoid', checks if the given types have an inhabitant--- Functions like 'pmIsSatisfiable', 'nonVoid' and 'testInhabited' plug these--- together as they see fit.-newtype SatisfiabilityCheck = SC (Delta -> DsM (Maybe Delta))---- | Check the given 'Delta' for satisfiability by the given--- 'SatisfiabilityCheck'. Return 'Just' a new, potentially extended, 'Delta' if--- successful, and 'Nothing' otherwise.-runSatisfiabilityCheck :: Delta -> SatisfiabilityCheck -> DsM (Maybe Delta)-runSatisfiabilityCheck delta (SC chk) = chk delta---- | Allowing easy composition of 'SatisfiabilityCheck's.-instance Semigroup SatisfiabilityCheck where- -- This is @a >=> b@ from MaybeT DsM- SC a <> SC b = SC c- where- c delta = a delta >>= \case- Nothing -> pure Nothing- Just delta' -> b delta'--instance Monoid SatisfiabilityCheck where- -- We only need this because of mconcat (which we use in place of sconcat,- -- which requires NonEmpty lists as argument, making all call sites ugly)- mempty = SC (pure . Just)------------------------------------ * Oracle transition function---- | Given a conlike's term constraints, type constraints, and strict argument--- types, check if they are satisfiable.--- (In other words, this is the ⊢_Sat oracle judgment from the GADTs Meet--- Their Match paper.)------ Taking strict argument types into account is something which was not--- discussed in GADTs Meet Their Match. For an explanation of what role they--- serve, see @Note [Strict argument type constraints]@.-pmIsSatisfiable- :: Delta -- ^ The ambient term and type constraints- -- (known to be satisfiable).- -> Bag TyCt -- ^ The new type constraints.- -> Bag TmCt -- ^ The new term constraints.- -> [Type] -- ^ The strict argument types.- -> DsM (Maybe Delta)- -- ^ @'Just' delta@ if the constraints (@delta@) are- -- satisfiable, and each strict argument type is inhabitable.- -- 'Nothing' otherwise.-pmIsSatisfiable amb_cs new_ty_cs new_tm_cs strict_arg_tys =- -- The order is important here! Check the new type constraints before we check- -- whether strict argument types are inhabited given those constraints.- runSatisfiabilityCheck amb_cs $ mconcat- [ tyIsSatisfiable True new_ty_cs- , tmIsSatisfiable new_tm_cs- , tysAreNonVoid initRecTc strict_arg_tys- ]---------------------------- * Type normalisation---- | The return value of 'pmTopNormaliseType'-data TopNormaliseTypeResult- = NoChange Type- -- ^ 'tcNormalise' failed to simplify the type and 'topNormaliseTypeX' was- -- unable to reduce the outermost type application, so the type came out- -- unchanged.- | NormalisedByConstraints Type- -- ^ 'tcNormalise' was able to simplify the type with some local constraint- -- from the type oracle, but 'topNormaliseTypeX' couldn't identify a type- -- redex.- | HadRedexes Type [(Type, DataCon, Type)] Type- -- ^ 'tcNormalise' may or may not been able to simplify the type, but- -- 'topNormaliseTypeX' made progress either way and got rid of at least one- -- outermost type or data family redex or newtype.- -- The first field is the last type that was reduced solely through type- -- family applications (possibly just the 'tcNormalise'd type). This is the- -- one that is equal (in source Haskell) to the initial type.- -- The third field is the type that we get when also looking through data- -- family applications and newtypes. This would be the representation type in- -- Core (modulo casts).- -- The second field is the list of Newtype 'DataCon's that we looked through- -- in the chain of reduction steps between the Source type and the Core type.- -- We also keep the type of the DataCon application and its field, so that we- -- don't have to reconstruct it in 'inhabitationCandidates' and- -- 'provideEvidence'.- -- For an example, see Note [Type normalisation].---- | Just give me the potentially normalised source type, unchanged or not!-normalisedSourceType :: TopNormaliseTypeResult -> Type-normalisedSourceType (NoChange ty) = ty-normalisedSourceType (NormalisedByConstraints ty) = ty-normalisedSourceType (HadRedexes ty _ _) = ty---- | Return the fields of 'HadRedexes'. Returns appropriate defaults in the--- other cases.-tntrGuts :: TopNormaliseTypeResult -> (Type, [(Type, DataCon, Type)], Type)-tntrGuts (NoChange ty) = (ty, [], ty)-tntrGuts (NormalisedByConstraints ty) = (ty, [], ty)-tntrGuts (HadRedexes src_ty ds core_ty) = (src_ty, ds, core_ty)--instance Outputable TopNormaliseTypeResult where- ppr (NoChange ty) = text "NoChange" <+> ppr ty- ppr (NormalisedByConstraints ty) = text "NormalisedByConstraints" <+> ppr ty- ppr (HadRedexes src_ty ds core_ty) = text "HadRedexes" <+> braces fields- where- fields = fsep (punctuate comma [ text "src_ty =" <+> ppr src_ty- , text "newtype_dcs =" <+> ppr ds- , text "core_ty =" <+> ppr core_ty ])--pmTopNormaliseType :: TyState -> Type -> DsM TopNormaliseTypeResult--- ^ Get rid of *outermost* (or toplevel)--- * type function redex--- * data family redex--- * newtypes------ Behaves like `topNormaliseType_maybe`, but instead of returning a--- coercion, it returns useful information for issuing pattern matching--- warnings. See Note [Type normalisation] for details.--- It also initially 'tcNormalise's the type with the bag of local constraints.------ See 'TopNormaliseTypeResult' for the meaning of the return value.------ NB: Normalisation can potentially change kinds, if the head of the type--- is a type family with a variable result kind. I (Richard E) can't think--- of a way to cause trouble here, though.-pmTopNormaliseType (TySt inert) typ- = do env <- dsGetFamInstEnvs- -- Before proceeding, we chuck typ into the constraint solver, in case- -- solving for given equalities may reduce typ some. See- -- "Wrinkle: local equalities" in Note [Type normalisation].- (_, mb_typ') <- initTcDsForSolver $ tcNormalise inert typ- -- If tcNormalise didn't manage to simplify the type, continue anyway.- -- We might be able to reduce type applications nonetheless!- let typ' = fromMaybe typ mb_typ'- -- Now we look with topNormaliseTypeX through type and data family- -- applications and newtypes, which tcNormalise does not do.- -- See also 'TopNormaliseTypeResult'.- pure $ case topNormaliseTypeX (stepper env) comb typ' of- Nothing- | Nothing <- mb_typ' -> NoChange typ- | otherwise -> NormalisedByConstraints typ'- Just ((ty_f,tm_f), ty) -> HadRedexes src_ty newtype_dcs core_ty- where- src_ty = eq_src_ty ty (typ' : ty_f [ty])- newtype_dcs = tm_f []- core_ty = ty- where- -- Find the first type in the sequence of rewrites that is a data type,- -- newtype, or a data family application (not the representation tycon!).- -- This is the one that is equal (in source Haskell) to the initial type.- -- If none is found in the list, then all of them are type family- -- applications, so we simply return the last one, which is the *simplest*.- eq_src_ty :: Type -> [Type] -> Type- eq_src_ty ty tys = maybe ty id (find is_closed_or_data_family tys)-- is_closed_or_data_family :: Type -> Bool- is_closed_or_data_family ty = pmIsClosedType ty || isDataFamilyAppType ty-- -- For efficiency, represent both lists as difference lists.- -- comb performs the concatenation, for both lists.- comb (tyf1, tmf1) (tyf2, tmf2) = (tyf1 . tyf2, tmf1 . tmf2)-- stepper env = newTypeStepper `composeSteppers` tyFamStepper env-- -- A 'NormaliseStepper' that unwraps newtypes, careful not to fall into- -- a loop. If it would fall into a loop, it produces 'NS_Abort'.- newTypeStepper :: NormaliseStepper ([Type] -> [Type],[(Type, DataCon, Type)] -> [(Type, DataCon, Type)])- newTypeStepper rec_nts tc tys- | Just (ty', _co) <- instNewTyCon_maybe tc tys- , let orig_ty = TyConApp tc tys- = case checkRecTc rec_nts tc of- Just rec_nts' -> let tyf = (orig_ty:)- tmf = ((orig_ty, tyConSingleDataCon tc, ty'):)- in NS_Step rec_nts' ty' (tyf, tmf)- Nothing -> NS_Abort- | otherwise- = NS_Done-- tyFamStepper :: FamInstEnvs -> NormaliseStepper ([Type] -> [Type], a -> a)- tyFamStepper env rec_nts tc tys -- Try to step a type/data family- = case topReduceTyFamApp_maybe env tc tys of- Just (_, rhs, _) -> NS_Step rec_nts rhs ((rhs:), id)- _ -> NS_Done---- | Returns 'True' if the argument 'Type' is a fully saturated application of--- a closed type constructor.------ Closed type constructors are those with a fixed right hand side, as--- opposed to e.g. associated types. These are of particular interest for--- pattern-match coverage checking, because GHC can exhaustively consider all--- possible forms that values of a closed type can take on.------ Note that this function is intended to be used to check types of value-level--- patterns, so as a consequence, the 'Type' supplied as an argument to this--- function should be of kind @Type@.-pmIsClosedType :: Type -> Bool-pmIsClosedType ty- = case splitTyConApp_maybe ty of- Just (tc, ty_args)- | is_algebraic_like tc && not (isFamilyTyCon tc)- -> ASSERT2( ty_args `lengthIs` tyConArity tc, ppr ty ) True- _other -> False- where- -- This returns True for TyCons which /act like/ algebraic types.- -- (See "Type#type_classification" for what an algebraic type is.)- --- -- This is qualified with \"like\" because of a particular special- -- case: TYPE (the underlyind kind behind Type, among others). TYPE- -- is conceptually a datatype (and thus algebraic), but in practice it is- -- a primitive builtin type, so we must check for it specially.- --- -- NB: it makes sense to think of TYPE as a closed type in a value-level,- -- pattern-matching context. However, at the kind level, TYPE is certainly- -- not closed! Since this function is specifically tailored towards pattern- -- matching, however, it's OK to label TYPE as closed.- is_algebraic_like :: TyCon -> Bool- is_algebraic_like tc = isAlgTyCon tc || tc == tYPETyCon--{- Note [Type normalisation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Constructs like -XEmptyCase or a previous unsuccessful pattern match on a data-constructor place a non-void constraint on the matched thing. This means that it-boils down to checking whether the type of the scrutinee is inhabited. Function-pmTopNormaliseType gets rid of the outermost type function/data family redex and-newtypes, in search of an algebraic type constructor, which is easier to check-for inhabitation.--It returns 3 results instead of one, because there are 2 subtle points:-1. Newtypes are isomorphic to the underlying type in core but not in the source- language,-2. The representational data family tycon is used internally but should not be- shown to the user--Hence, if pmTopNormaliseType env ty_cs ty = Just (src_ty, dcs, core_ty),-then- (a) src_ty is the rewritten type which we can show to the user. That is, the- type we get if we rewrite type families but not data families or- newtypes.- (b) dcs is the list of newtype constructors "skipped", every time we normalise- a newtype to its core representation, we keep track of the source data- constructor. For convenience, we also track the type we unwrap and the- type of its field. Example: @Down 42@ => @[(Down @Int, Down, Int)]- (c) core_ty is the rewritten type. That is,- pmTopNormaliseType env ty_cs ty = Just (src_ty, dcs, core_ty)- implies- topNormaliseType_maybe env ty = Just (co, core_ty)- for some coercion co.--To see how all cases come into play, consider the following example:-- data family T a :: *- data instance T Int = T1 | T2 Bool- -- Which gives rise to FC:- -- data T a- -- data R:TInt = T1 | T2 Bool- -- axiom ax_ti : T Int ~R R:TInt-- newtype G1 = MkG1 (T Int)- newtype G2 = MkG2 G1-- type instance F Int = F Char- type instance F Char = G2--In this case pmTopNormaliseType env ty_cs (F Int) results in-- Just (G2, [(G2,MkG2,G1),(G1,MkG1,T Int)], R:TInt)--Which means that in source Haskell:- - G2 is equivalent to F Int (in contrast, G1 isn't).- - if (x : R:TInt) then (MkG2 (MkG1 x) : F Int).---------- Wrinkle: Local equalities--------Given the following type family:-- type family F a- type instance F Int = Void--Should the following program (from #14813) be considered exhaustive?-- f :: (i ~ Int) => F i -> a- f x = case x of {}--You might think "of course, since `x` is obviously of type Void". But the-idType of `x` is technically F i, not Void, so if we pass F i to-inhabitationCandidates, we'll mistakenly conclude that `f` is non-exhaustive.-In order to avoid this pitfall, we need to normalise the type passed to-pmTopNormaliseType, using the constraint solver to solve for any local-equalities (such as i ~ Int) that may be in scope.--}--------------------- * Type oracle---- | Allocates a fresh 'EvVar' name for 'PredTy's.-nameTyCt :: PredType -> DsM EvVar-nameTyCt pred_ty = do- unique <- getUniqueM- let occname = mkVarOccFS (fsLit ("pm_"++show unique))- idname = mkInternalName unique occname noSrcSpan- return (mkLocalIdOrCoVar idname Many pred_ty)---- | Add some extra type constraints to the 'TyState'; return 'Nothing' if we--- find a contradiction (e.g. @Int ~ Bool@).-tyOracle :: TyState -> Bag PredType -> DsM (Maybe TyState)-tyOracle (TySt inert) cts- = do { evs <- traverse nameTyCt cts- ; let new_inert = inert `unionBags` evs- ; tracePm "tyOracle" (ppr cts)- ; ((_warns, errs), res) <- initTcDsForSolver $ tcCheckSatisfiability new_inert- ; case res of- Just True -> return (Just (TySt new_inert))- Just False -> return Nothing- Nothing -> pprPanic "tyOracle" (vcat $ pprErrMsgBagWithLoc errs) }---- | A 'SatisfiabilityCheck' based on new type-level constraints.--- Returns a new 'Delta' if the new constraints are compatible with existing--- ones. Doesn't bother calling out to the type oracle if the bag of new type--- constraints was empty. Will only recheck 'PossibleMatches' in the term oracle--- for emptiness if the first argument is 'True'.-tyIsSatisfiable :: Bool -> Bag PredType -> SatisfiabilityCheck-tyIsSatisfiable recheck_complete_sets new_ty_cs = SC $ \delta ->- if isEmptyBag new_ty_cs- then pure (Just delta)- else tyOracle (delta_ty_st delta) new_ty_cs >>= \case- Nothing -> pure Nothing- Just ty_st' -> do- let delta' = delta{ delta_ty_st = ty_st' }- if recheck_complete_sets- then ensureAllPossibleMatchesInhabited delta'- else pure (Just delta')---{- *********************************************************************-* *- DIdEnv with sharing-* *-********************************************************************* -}---{- *********************************************************************-* *- TmState- What we know about terms-* *-********************************************************************* -}--{- Note [The Pos/Neg invariant]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Invariant applying to each VarInfo: Whenever we have @(C, [y,z])@ in 'vi_pos',-any entry in 'vi_neg' must be incomparable to C (return Nothing) according to-'eqPmAltCons'. Those entries that are comparable either lead to a refutation-or are redundant. Examples:-* @x ~ Just y@, @x /~ [Just]@. 'eqPmAltCon' returns @Equal@, so refute.-* @x ~ Nothing@, @x /~ [Just]@. 'eqPmAltCon' returns @Disjoint@, so negative- info is redundant and should be discarded.-* @x ~ I# y@, @x /~ [4,2]@. 'eqPmAltCon' returns @PossiblyOverlap@, so orthogal.- We keep this info in order to be able to refute a redundant match on i.e. 4- later on.--This carries over to pattern synonyms and overloaded literals. Say, we have- pattern Just42 = Just 42- case Just42 of x- Nothing -> ()- Just _ -> ()-Even though we had a solution for the value abstraction called x here in form-of a PatSynCon (Just42,[]), this solution is incomparable to both Nothing and-Just. Hence we retain the info in vi_neg, which eventually allows us to detect-the complete pattern match.--The Pos/Neg invariant extends to vi_cache, which stores essentially positive-information. We make sure that vi_neg and vi_cache never overlap. This isn't-strictly necessary since vi_cache is just a cache, so doesn't need to be-accurate: Every suggestion of a possible ConLike from vi_cache might be-refutable by the type oracle anyway. But it helps to maintain sanity while-debugging traces.--Note [Why record both positive and negative info?]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-You might think that knowing positive info (like x ~ Just y) would render-negative info irrelevant, but not so because of pattern synonyms. E.g we might-know that x cannot match (Foo 4), where pattern Foo p = Just p--Also overloaded literals themselves behave like pattern synonyms. E.g if-postively we know that (x ~ I# y), we might also negatively want to record that-x does not match 45 f 45 = e2 f (I# 22#) = e3 f 45 = e4 ---Overlapped--Note [TmState invariants]-~~~~~~~~~~~~~~~~~~~~~~~~~-The term oracle state is never obviously (i.e., without consulting the type-oracle) contradictory. This implies a few invariants:-* Whenever vi_pos overlaps with vi_neg according to 'eqPmAltCon', we refute.- This is implied by the Note [Pos/Neg invariant].-* Whenever vi_neg subsumes a COMPLETE set, we refute. We consult vi_cache to- detect this, but we could just compare whole COMPLETE sets to vi_neg every- time, if it weren't for performance.--Maintaining these invariants in 'addVarCt' (the core of the term oracle) and-'addNotConCt' is subtle.-* Merging VarInfos. Example: Add the fact @x ~ y@ (see 'equate').- - (COMPLETE) If we had @x /~ True@ and @y /~ False@, then we get- @x /~ [True,False]@. This is vacuous by matter of comparing to the built-in- COMPLETE set, so should refute.- - (Pos/Neg) If we had @x /~ True@ and @y ~ True@, we have to refute.-* Adding positive information. Example: Add the fact @x ~ K ys@ (see 'addConCt')- - (Neg) If we had @x /~ K@, refute.- - (Pos) If we had @x ~ K2@, and that contradicts the new solution according to- 'eqPmAltCon' (ex. K2 is [] and K is (:)), then refute.- - (Refine) If we had @x /~ K zs@, unify each y with each z in turn.-* Adding negative information. Example: Add the fact @x /~ Nothing@ (see 'addNotConCt')- - (Refut) If we have @x ~ K ys@, refute.- - (COMPLETE) If K=Nothing and we had @x /~ Just@, then we get- @x /~ [Just,Nothing]@. This is vacuous by matter of comparing to the built-in- COMPLETE set, so should refute.--Note that merging VarInfo in equate can be done by calling out to 'addConCt' and-'addNotConCt' for each of the facts individually.--Note [Representation of Strings in TmState]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Instead of treating regular String literals as a PmLits, we treat it as a list-of characters in the oracle for better overlap reasoning. The following example-shows why:-- f :: String -> ()- f ('f':_) = ()- f "foo" = ()- f _ = ()--The second case is redundant, and we like to warn about it. Therefore either-the oracle will have to do some smart conversion between the list and literal-representation or treat is as the list it really is at runtime.--The "smart conversion" has the advantage of leveraging the more compact literal-representation wherever possible, but is really nasty to get right with negative-equalities: Just think of how to encode @x /= "foo"@.-The "list" option is far simpler, but incurs some overhead in representation and-warning messages (which can be alleviated by someone with enough dedication).--}---- | A 'SatisfiabilityCheck' based on new term-level constraints.--- Returns a new 'Delta' if the new constraints are compatible with existing--- ones.-tmIsSatisfiable :: Bag TmCt -> SatisfiabilityCheck-tmIsSatisfiable new_tm_cs = SC $ \delta -> runMaybeT $ foldlM addTmCt delta new_tm_cs---------------------------- * Looking up VarInfo--emptyVarInfo :: Id -> VarInfo-emptyVarInfo x = VI (idType x) [] emptyPmAltConSet NoPM--lookupVarInfo :: TmState -> Id -> VarInfo--- (lookupVarInfo tms x) tells what we know about 'x'-lookupVarInfo (TmSt env _) x = fromMaybe (emptyVarInfo x) (lookupSDIE env x)--initPossibleMatches :: TyState -> VarInfo -> DsM VarInfo-initPossibleMatches ty_st vi@VI{ vi_ty = ty, vi_cache = NoPM } = do- -- New evidence might lead to refined info on ty, in turn leading to discovery- -- of a COMPLETE set.- res <- pmTopNormaliseType ty_st ty- let ty' = normalisedSourceType res- case splitTyConApp_maybe ty' of- Nothing -> pure vi{ vi_ty = ty' }- Just (tc, [_])- | tc == tYPETyCon- -- TYPE acts like an empty data type on the term-level (#14086), but- -- it is a PrimTyCon, so tyConDataCons_maybe returns Nothing. Hence a- -- special case.- -> pure vi{ vi_ty = ty', vi_cache = PM (pure emptyUniqDSet) }- Just (tc, tc_args) -> do- -- See Note [COMPLETE sets on data families]- (tc_rep, tc_fam) <- case tyConFamInst_maybe tc of- Just (tc_fam, _) -> pure (tc, tc_fam)- Nothing -> do- env <- dsGetFamInstEnvs- let (tc_rep, _tc_rep_args, _co) = tcLookupDataFamInst env tc tc_args- pure (tc_rep, tc)- -- Note that the common case here is tc_rep == tc_fam- let mb_rdcs = map RealDataCon <$> tyConDataCons_maybe tc_rep- let rdcs = maybeToList mb_rdcs- -- NB: tc_fam, because COMPLETE sets are associated with the parent data- -- family TyCon- pragmas <- dsGetCompleteMatches tc_fam- let fams = mapM dsLookupConLike . completeMatchConLikes- pscs <- mapM fams pragmas- -- pprTrace "initPossibleMatches" (ppr ty $$ ppr ty' $$ ppr tc_rep <+> ppr tc_fam <+> ppr tc_args $$ ppr (rdcs ++ pscs)) (return ())- case NonEmpty.nonEmpty (rdcs ++ pscs) of- Nothing -> pure vi{ vi_ty = ty' } -- Didn't find any COMPLETE sets- Just cs -> pure vi{ vi_ty = ty', vi_cache = PM (mkUniqDSet <$> cs) }-initPossibleMatches _ vi = pure vi---- | @initLookupVarInfo ts x@ looks up the 'VarInfo' for @x@ in @ts@ and tries--- to initialise the 'vi_cache' component if it was 'NoPM' through--- 'initPossibleMatches'.-initLookupVarInfo :: Delta -> Id -> DsM VarInfo-initLookupVarInfo MkDelta{ delta_tm_st = ts, delta_ty_st = ty_st } x- = initPossibleMatches ty_st (lookupVarInfo ts x)--{- Note [COMPLETE sets on data families]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-User-defined COMPLETE sets involving data families are attached to the family-TyCon, whereas the built-in COMPLETE set is attached to a data family instance's-representation TyCon. This matters for COMPLETE sets involving both DataCons-and PatSyns (from #17207):-- data family T a- data family instance T () = A | B- pattern C = B- {-# COMPLETE A, C #-}- f :: T () -> ()- f A = ()- f C = ()--The match on A is actually wrapped in a CoPat, matching impedance between T ()-and its representation TyCon, which we translate as-@x | let y = x |> co, A <- y@ in PmCheck.--Which TyCon should we use for looking up the COMPLETE set? The representation-TyCon from the match on A would only reveal the built-in COMPLETE set, while the-data family TyCon would only give the user-defined one. But when initialising-the PossibleMatches for a given Type, we want to do so only once, because-merging different COMPLETE sets after the fact is very complicated and possibly-inefficient.--So in fact, we just *drop* the coercion arising from the CoPat when handling-handling the constraint @y ~ x |> co@ in addCoreCt, just equating @y ~ x@.-We then handle the fallout in initPossibleMatches, which has to get a hand at-both the representation TyCon tc_rep and the parent data family TyCon tc_fam.-It considers three cases after having established that the Type is a TyConApp:--1. The TyCon is a vanilla data type constructor-2. The TyCon is tc_rep-3. The TyCon is tc_fam--1. is simple and subsumed by the handling of the other two.-We check for case 2. by 'tyConFamInst_maybe' and get the tc_fam out.-Otherwise (3.), we try to lookup the data family instance at that particular-type to get out the tc_rep. In case 1., this will just return the original-TyCon, so tc_rep = tc_fam afterwards.--}----------------------------------------------------- * Exported utility functions querying 'Delta'---- | Check whether adding a constraint @x ~ BOT@ to 'Delta' succeeds.-canDiverge :: Delta -> Id -> Bool-canDiverge delta@MkDelta{ delta_tm_st = ts } x- | VI _ pos neg _ <- lookupVarInfo ts x- = isEmptyPmAltConSet neg && all pos_can_diverge pos- where- pos_can_diverge (PmAltConLike (RealDataCon dc), _, [y])- -- See Note [Divergence of Newtype matches]- | isNewTyCon (dataConTyCon dc) = canDiverge delta y- pos_can_diverge _ = False--{- Note [Divergence of Newtype matches]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Newtypes behave rather strangely when compared to ordinary DataCons. In a-pattern-match, they behave like a irrefutable (lazy) match, but for inhabitation-testing purposes (e.g. at construction sites), they behave rather like a DataCon-with a *strict* field, because they don't contribute their own bottom and are-inhabited iff the wrapped type is inhabited.--This distinction becomes apparent in #17248:-- newtype T2 a = T2 a- g _ True = ()- g (T2 _) True = ()- g !_ True = ()--If we treat Newtypes like we treat regular DataCons, we would mark the third-clause as redundant, which clearly is unsound. The solution:-1. When compiling the PmCon guard in 'pmCompileTree', don't add a @DivergeIf@,- because the match will never diverge.-2. Regard @T2 x@ as 'canDiverge' iff @x@ 'canDiverge'. E.g. @T2 x ~ _|_@ <=>- @x ~ _|_@. This way, the third clause will still be marked as inaccessible- RHS instead of redundant.-3. When testing for inhabitants ('mkOneConFull'), we regard the newtype field as- strict, so that the newtype is inhabited iff its field is inhabited.--}--lookupRefuts :: Uniquable k => Delta -> k -> [PmAltCon]--- Unfortunately we need the extra bit of polymorphism and the unfortunate--- duplication of lookupVarInfo here.-lookupRefuts MkDelta{ delta_tm_st = ts@(TmSt (SDIE env) _) } k =- case lookupUDFM_Directly env (getUnique k) of- Nothing -> []- Just (Indirect y) -> pmAltConSetElems (vi_neg (lookupVarInfo ts y))- Just (Entry vi) -> pmAltConSetElems (vi_neg vi)--isDataConSolution :: (PmAltCon, [TyVar], [Id]) -> Bool-isDataConSolution (PmAltConLike (RealDataCon _), _, _) = True-isDataConSolution _ = False---- @lookupSolution delta x@ picks a single solution ('vi_pos') of @x@ from--- possibly many, preferring 'RealDataCon' solutions whenever possible.-lookupSolution :: Delta -> Id -> Maybe (PmAltCon, [TyVar], [Id])-lookupSolution delta x = case vi_pos (lookupVarInfo (delta_tm_st delta) x) of- [] -> Nothing- pos- | Just sol <- find isDataConSolution pos -> Just sol- | otherwise -> Just (head pos)------------------------------------ * Adding facts to the oracle---- | A term constraint.-data TmCt- = TmVarCt !Id !Id- -- ^ @TmVarCt x y@ encodes "x ~ y", equating @x@ and @y@.- | TmCoreCt !Id !CoreExpr- -- ^ @TmCoreCt x e@ encodes "x ~ e", equating @x@ with the 'CoreExpr' @e@.- | TmConCt !Id !PmAltCon ![TyVar] ![Id]- -- ^ @TmConCt x K tvs ys@ encodes "x ~ K @tvs ys", equating @x@ with the 'PmAltCon'- -- application @K @tvs ys@.- | TmNotConCt !Id !PmAltCon- -- ^ @TmNotConCt x K@ encodes "x /~ K", asserting that @x@ can't be headed- -- by @K@.- | TmBotCt !Id- -- ^ @TmBotCt x@ encodes "x ~ ⊥", equating @x@ to ⊥.- -- by @K@.- | TmNotBotCt !Id- -- ^ @TmNotBotCt x y@ encodes "x /~ ⊥", asserting that @x@ can't be ⊥.--instance Outputable TmCt where- ppr (TmVarCt x y) = ppr x <+> char '~' <+> ppr y- ppr (TmCoreCt x e) = ppr x <+> char '~' <+> ppr e- ppr (TmConCt x con tvs args) = ppr x <+> char '~' <+> hsep (ppr con : pp_tvs ++ pp_args)- where- pp_tvs = map ((<> char '@') . ppr) tvs- pp_args = map ppr args- ppr (TmNotConCt x con) = ppr x <+> text "/~" <+> ppr con- ppr (TmBotCt x) = ppr x <+> text "~ ⊥"- ppr (TmNotBotCt x) = ppr x <+> text "/~ ⊥"--type TyCt = PredType---- | An oracle constraint.-data PmCt- = PmTyCt !TyCt- -- ^ @PmTy pred_ty@ carries 'PredType's, for example equality constraints.- | PmTmCt !TmCt- -- ^ A term constraint.--type PmCts = Bag PmCt--pattern PmVarCt :: Id -> Id -> PmCt-pattern PmVarCt x y = PmTmCt (TmVarCt x y)-pattern PmCoreCt :: Id -> CoreExpr -> PmCt-pattern PmCoreCt x e = PmTmCt (TmCoreCt x e)-pattern PmConCt :: Id -> PmAltCon -> [TyVar] -> [Id] -> PmCt-pattern PmConCt x con tvs args = PmTmCt (TmConCt x con tvs args)-pattern PmNotConCt :: Id -> PmAltCon -> PmCt-pattern PmNotConCt x con = PmTmCt (TmNotConCt x con)-pattern PmBotCt :: Id -> PmCt-pattern PmBotCt x = PmTmCt (TmBotCt x)-pattern PmNotBotCt :: Id -> PmCt-pattern PmNotBotCt x = PmTmCt (TmNotBotCt x)-{-# COMPLETE PmTyCt, PmVarCt, PmCoreCt, PmConCt, PmNotConCt, PmBotCt, PmNotBotCt #-}--instance Outputable PmCt where- ppr (PmTyCt pred_ty) = ppr pred_ty- ppr (PmTmCt tm_ct) = ppr tm_ct---- | Adds new constraints to 'Delta' and returns 'Nothing' if that leads to a--- contradiction.-addPmCts :: Delta -> PmCts -> DsM (Maybe Delta)--- See Note [TmState invariants].-addPmCts delta cts = do- let (ty_cts, tm_cts) = partitionTyTmCts cts- runSatisfiabilityCheck delta $ mconcat- [ tyIsSatisfiable True (listToBag ty_cts)- , tmIsSatisfiable (listToBag tm_cts)- ]--partitionTyTmCts :: PmCts -> ([TyCt], [TmCt])-partitionTyTmCts = partitionEithers . map to_either . toList- where- to_either (PmTyCt pred_ty) = Left pred_ty- to_either (PmTmCt tm_ct) = Right tm_ct---- | Adds a single term constraint by dispatching to the various term oracle--- functions.-addTmCt :: Delta -> TmCt -> MaybeT DsM Delta-addTmCt delta (TmVarCt x y) = addVarCt delta x y-addTmCt delta (TmCoreCt x e) = addCoreCt delta x e-addTmCt delta (TmConCt x con tvs args) = addConCt delta x con tvs args-addTmCt delta (TmNotConCt x con) = addNotConCt delta x con-addTmCt delta (TmBotCt x) = addBotCt delta x-addTmCt delta (TmNotBotCt x) = addNotBotCt delta x---- | Adds the constraint @x ~ ⊥@, e.g. that evaluation of a particular 'Id' @x@--- surely diverges.------ Only that's a lie, because we don't currently preserve the fact in 'Delta'--- after we checked compatibility. See Note [Preserving TmBotCt]-addBotCt :: Delta -> Id -> MaybeT DsM Delta-addBotCt delta x- | canDiverge delta x = pure delta- | otherwise = mzero--{- Note [Preserving TmBotCt]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Whenever we add a new constraint to 'Delta' via 'addTmCt', we want to check it-for compatibility with existing constraints in the modeled indert set and then-add it the constraint itself to the inert set.-For a 'TmBotCt' @x ~ ⊥@ we don't actually add it to the inert set after checking-it for compatibility with 'Delta'.-And that is fine in the context of the patter-match checking algorithm!-Whenever we add a 'TmBotCt' (we only do so for checking divergence of bang-patterns and strict constructor matches), we don't add any more constraints to-the inert set afterwards, so we don't need to preserve it.--}---- | Record a @x ~/ K@ constraint, e.g. that a particular 'Id' @x@ can't--- take the shape of a 'PmAltCon' @K@ in the 'Delta' and return @Nothing@ if--- that leads to a contradiction.--- See Note [TmState invariants].-addNotConCt :: Delta -> Id -> PmAltCon -> MaybeT DsM Delta-addNotConCt delta@MkDelta{ delta_tm_st = TmSt env reps } x nalt = do- vi@(VI _ pos neg pm) <- lift (initLookupVarInfo delta x)- -- 1. Bail out quickly when nalt contradicts a solution- let contradicts nalt (cl, _tvs, _args) = eqPmAltCon cl nalt == Equal- guard (not (any (contradicts nalt) pos))- -- 2. Only record the new fact when it's not already implied by one of the- -- solutions- let implies nalt (cl, _tvs, _args) = eqPmAltCon cl nalt == Disjoint- let neg'- | any (implies nalt) pos = neg- -- See Note [Completeness checking with required Thetas]- | hasRequiredTheta nalt = neg- | otherwise = extendPmAltConSet neg nalt- let vi_ext = vi{ vi_neg = neg' }- -- 3. Make sure there's at least one other possible constructor- vi' <- case nalt of- PmAltConLike cl- -> MaybeT (ensureInhabited delta vi_ext{ vi_cache = markMatched cl pm })- _ -> pure vi_ext- pure delta{ delta_tm_st = TmSt (setEntrySDIE env x vi') reps }--hasRequiredTheta :: PmAltCon -> Bool-hasRequiredTheta (PmAltConLike cl) = notNull req_theta- where- (_,_,_,_,req_theta,_,_) = conLikeFullSig cl-hasRequiredTheta _ = False--{- Note [Completeness checking with required Thetas]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider the situation in #11224-- import Text.Read (readMaybe)- pattern PRead :: Read a => () => a -> String- pattern PRead x <- (readMaybe -> Just x)- f :: String -> Int- f (PRead x) = x- f (PRead xs) = length xs- f _ = 0--Is the first match exhaustive on the PRead synonym? Should the second line thus-deemed redundant? The answer is, of course, No! The required theta is like a-hidden parameter which must be supplied at the pattern match site, so PRead-is much more like a view pattern (where behavior depends on the particular value-passed in).-The simple solution here is to forget in 'addNotConCt' that we matched-on synonyms with a required Theta like @PRead@, so that subsequent matches on-the same constructor are never flagged as redundant. The consequence is that-we no longer detect the actually redundant match in-- g :: String -> Int- g (PRead x) = x- g (PRead y) = y -- redundant!- g _ = 0--But that's a small price to pay, compared to the proper solution here involving-storing required arguments along with the PmAltConLike in 'vi_neg'.--}---- | Guess the universal argument types of a ConLike from an instantiation of--- its result type. Rather easy for DataCons, but not so much for PatSynCons.--- See Note [Pattern synonym result type] in "GHC.Core.PatSyn".-guessConLikeUnivTyArgsFromResTy :: FamInstEnvs -> Type -> ConLike -> Maybe [Type]-guessConLikeUnivTyArgsFromResTy env res_ty (RealDataCon _) = do- (tc, tc_args) <- splitTyConApp_maybe res_ty- -- Consider data families: In case of a DataCon, we need to translate to- -- the representation TyCon. For PatSyns, they are relative to the data- -- family TyCon, so we don't need to translate them.- let (_, tc_args', _) = tcLookupDataFamInst env tc tc_args- Just tc_args'-guessConLikeUnivTyArgsFromResTy _ res_ty (PatSynCon ps) = do- -- We are successful if we managed to instantiate *every* univ_tv of con.- -- This is difficult and bound to fail in some cases, see- -- Note [Pattern synonym result type] in GHC.Core.PatSyn. So we just try our best- -- here and be sure to return an instantiation when we can substitute every- -- universally quantified type variable.- -- We *could* instantiate all the other univ_tvs just to fresh variables, I- -- suppose, but that means we get weird field types for which we don't know- -- anything. So we prefer to keep it simple here.- let (univ_tvs,_,_,_,_,con_res_ty) = patSynSig ps- subst <- tcMatchTy con_res_ty res_ty- traverse (lookupTyVar subst) univ_tvs---- | Adds the constraint @x ~/ ⊥@ to 'Delta'.------ But doesn't really commit to upholding that constraint in the future. This--- will be rectified in a follow-up patch. The status quo should work good--- enough for now.-addNotBotCt :: Delta -> Id -> MaybeT DsM Delta-addNotBotCt delta@MkDelta{ delta_tm_st = TmSt env reps } x = do- vi <- lift $ initLookupVarInfo delta x- vi' <- MaybeT $ ensureInhabited delta vi- -- vi' has probably constructed and then thinned out some PossibleMatches.- -- We want to cache that work- pure delta{ delta_tm_st = TmSt (setEntrySDIE env x vi') reps}--ensureInhabited :: Delta -> VarInfo -> DsM (Maybe VarInfo)- -- Returns (Just vi) if at least one member of each ConLike in the COMPLETE- -- set satisfies the oracle- --- -- Internally uses and updates the ConLikeSets in vi_cache.- --- -- NB: Does /not/ filter each ConLikeSet with the oracle; members may- -- remain that do not statisfy it. This lazy approach just- -- avoids doing unnecessary work.-ensureInhabited delta vi = fmap (set_cache vi) <$> test (vi_cache vi) -- This would be much less tedious with lenses- where- set_cache vi cache = vi { vi_cache = cache }-- test NoPM = pure (Just NoPM)- test (PM ms) = runMaybeT (PM <$> traverse one_set ms)-- one_set cs = find_one_inh cs (uniqDSetToList cs)-- find_one_inh :: ConLikeSet -> [ConLike] -> MaybeT DsM ConLikeSet- -- (find_one_inh cs cls) iterates over cls, deleting from cs- -- any uninhabited elements of cls. Stop (returning Just cs)- -- when you see an inhabited element; return Nothing if all- -- are uninhabited- find_one_inh _ [] = mzero- find_one_inh cs (con:cons) = lift (inh_test con) >>= \case- True -> pure cs- False -> find_one_inh (delOneFromUniqDSet cs con) cons-- inh_test :: ConLike -> DsM Bool- -- @inh_test K@ Returns False if a non-bottom value @v::ty@ cannot possibly- -- be of form @K _ _ _@. Returning True is always sound.- --- -- It's like 'DataCon.dataConCannotMatch', but more clever because it takes- -- the facts in Delta into account.- inh_test con = do- env <- dsGetFamInstEnvs- case guessConLikeUnivTyArgsFromResTy env (vi_ty vi) con of- Nothing -> pure True -- be conservative about this- Just arg_tys -> do- (_tvs, _vars, ty_cs, strict_arg_tys) <- mkOneConFull arg_tys con- tracePm "inh_test" (ppr con $$ ppr ty_cs)- -- No need to run the term oracle compared to pmIsSatisfiable- fmap isJust <$> runSatisfiabilityCheck delta $ mconcat- -- Important to pass False to tyIsSatisfiable here, so that we won't- -- recursively call ensureAllPossibleMatchesInhabited, leading to an- -- endless recursion.- [ tyIsSatisfiable False ty_cs- , tysAreNonVoid initRecTc strict_arg_tys- ]---- | Checks if every 'VarInfo' in the term oracle has still an inhabited--- 'vi_cache', considering the current type information in 'Delta'.--- This check is necessary after having matched on a GADT con to weed out--- impossible matches.-ensureAllPossibleMatchesInhabited :: Delta -> DsM (Maybe Delta)-ensureAllPossibleMatchesInhabited delta@MkDelta{ delta_tm_st = TmSt env reps }- = runMaybeT (set_tm_cs_env delta <$> traverseSDIE go env)- where- set_tm_cs_env delta env = delta{ delta_tm_st = TmSt env reps }- go vi = MaybeT $- initPossibleMatches (delta_ty_st delta) vi >>= ensureInhabited delta------------------------------------------- * Term oracle unification procedure---- | Adds a @x ~ y@ constraint by trying to unify two 'Id's and record the--- gained knowledge in 'Delta'.------ Returns @Nothing@ when there's a contradiction. Returns @Just delta@--- when the constraint was compatible with prior facts, in which case @delta@--- has integrated the knowledge from the equality constraint.------ See Note [TmState invariants].-addVarCt :: Delta -> Id -> Id -> MaybeT DsM Delta-addVarCt delta@MkDelta{ delta_tm_st = TmSt env _ } x y- -- It's important that we never @equate@ two variables of the same equivalence- -- class, otherwise we might get cyclic substitutions.- -- Cf. 'extendSubstAndSolve' and- -- @testsuite/tests/pmcheck/should_compile/CyclicSubst.hs@.- | sameRepresentativeSDIE env x y = pure delta- | otherwise = equate delta x y---- | @equate ts@(TmSt env) x y@ merges the equivalence classes of @x@ and @y@ by--- adding an indirection to the environment.--- Makes sure that the positive and negative facts of @x@ and @y@ are--- compatible.--- Preconditions: @not (sameRepresentativeSDIE env x y)@------ See Note [TmState invariants].-equate :: Delta -> Id -> Id -> MaybeT DsM Delta-equate delta@MkDelta{ delta_tm_st = TmSt env reps } x y- = ASSERT( not (sameRepresentativeSDIE env x y) )- case (lookupSDIE env x, lookupSDIE env y) of- (Nothing, _) -> pure (delta{ delta_tm_st = TmSt (setIndirectSDIE env x y) reps })- (_, Nothing) -> pure (delta{ delta_tm_st = TmSt (setIndirectSDIE env y x) reps })- -- Merge the info we have for x into the info for y- (Just vi_x, Just vi_y) -> do- -- This assert will probably trigger at some point...- -- We should decide how to break the tie- MASSERT2( vi_ty vi_x `eqType` vi_ty vi_y, text "Not same type" )- -- First assume that x and y are in the same equivalence class- let env_ind = setIndirectSDIE env x y- -- Then sum up the refinement counters- let env_refs = setEntrySDIE env_ind y vi_y- let delta_refs = delta{ delta_tm_st = TmSt env_refs reps }- -- and then gradually merge every positive fact we have on x into y- let add_fact delta (cl, tvs, args) = addConCt delta y cl tvs args- delta_pos <- foldlM add_fact delta_refs (vi_pos vi_x)- -- Do the same for negative info- let add_refut delta nalt = addNotConCt delta y nalt- delta_neg <- foldlM add_refut delta_pos (pmAltConSetElems (vi_neg vi_x))- -- vi_cache will be updated in addNotConCt, so we are good to- -- go!- pure delta_neg---- | Add a @x ~ K tvs args ts@ constraint.--- @addConCt x K tvs args ts@ extends the substitution with a solution--- @x :-> (K, tvs, args)@ if compatible with the negative and positive info we--- have on @x@, reject (@Nothing@) otherwise.------ See Note [TmState invariants].-addConCt :: Delta -> Id -> PmAltCon -> [TyVar] -> [Id] -> MaybeT DsM Delta-addConCt delta@MkDelta{ delta_tm_st = TmSt env reps } x alt tvs args = do- VI ty pos neg cache <- lift (initLookupVarInfo delta x)- -- First try to refute with a negative fact- guard (not (elemPmAltConSet alt neg))- -- Then see if any of the other solutions (remember: each of them is an- -- additional refinement of the possible values x could take) indicate a- -- contradiction- guard (all ((/= Disjoint) . eqPmAltCon alt . fstOf3) pos)- -- Now we should be good! Add (alt, tvs, args) as a possible solution, or- -- refine an existing one- case find ((== Equal) . eqPmAltCon alt . fstOf3) pos of- Just (_con, other_tvs, other_args) -> do- -- We must unify existentially bound ty vars and arguments!- let ty_cts = equateTys (map mkTyVarTy tvs) (map mkTyVarTy other_tvs)- when (length args /= length other_args) $- lift $ tracePm "error" (ppr x <+> ppr alt <+> ppr args <+> ppr other_args)- let tm_cts = zipWithEqual "addConCt" PmVarCt args other_args- MaybeT $ addPmCts delta (listToBag ty_cts `unionBags` listToBag tm_cts)- Nothing -> do- let pos' = (alt, tvs, args):pos- pure delta{ delta_tm_st = TmSt (setEntrySDIE env x (VI ty pos' neg cache)) reps}--equateTys :: [Type] -> [Type] -> [PmCt]-equateTys ts us =- [ PmTyCt (mkPrimEqPred t u)- | (t, u) <- zipEqual "equateTys" ts us- -- The following line filters out trivial Refl constraints, so that we don't- -- need to initialise the type oracle that often- , not (eqType t u)- ]--------------------------------------------- * Enumerating inhabitation candidates---- | Information about a conlike that is relevant to coverage checking.--- It is called an \"inhabitation candidate\" since it is a value which may--- possibly inhabit some type, but only if its term constraints ('ic_tm_cs')--- and type constraints ('ic_ty_cs') are permitting, and if all of its strict--- argument types ('ic_strict_arg_tys') are inhabitable.--- See @Note [Strict argument type constraints]@.-data InhabitationCandidate =- InhabitationCandidate- { ic_cs :: PmCts- , ic_strict_arg_tys :: [Type]- }--instance Outputable InhabitationCandidate where- ppr (InhabitationCandidate cs strict_arg_tys) =- text "InhabitationCandidate" <+>- vcat [ text "ic_cs =" <+> ppr cs- , text "ic_strict_arg_tys =" <+> ppr strict_arg_tys ]--mkInhabitationCandidate :: Id -> DataCon -> DsM InhabitationCandidate--- Precondition: idType x is a TyConApp, so that tyConAppArgs in here is safe.-mkInhabitationCandidate x dc = do- let cl = RealDataCon dc- let tc_args = tyConAppArgs (idType x)- (ty_vars, arg_vars, ty_cs, strict_arg_tys) <- mkOneConFull tc_args cl- pure InhabitationCandidate- { ic_cs = PmTyCt <$> ty_cs `snocBag` PmConCt x (PmAltConLike cl) ty_vars arg_vars- , ic_strict_arg_tys = strict_arg_tys- }---- | Generate all 'InhabitationCandidate's for a given type. The result is--- either @'Left' ty@, if the type cannot be reduced to a closed algebraic type--- (or if it's one trivially inhabited, like 'Int'), or @'Right' candidates@,--- if it can. In this case, the candidates are the signature of the tycon, each--- one accompanied by the term- and type- constraints it gives rise to.--- See also Note [Checking EmptyCase Expressions]-inhabitationCandidates :: Delta -> Type- -> DsM (Either Type (TyCon, Id, [InhabitationCandidate]))-inhabitationCandidates MkDelta{ delta_ty_st = ty_st } ty = do- pmTopNormaliseType ty_st ty >>= \case- NoChange _ -> alts_to_check ty ty []- NormalisedByConstraints ty' -> alts_to_check ty' ty' []- HadRedexes src_ty dcs core_ty -> alts_to_check src_ty core_ty dcs- where- build_newtype :: (Type, DataCon, Type) -> Id -> DsM (Id, PmCt)- build_newtype (ty, dc, _arg_ty) x = do- -- ty is the type of @dc x@. It's a @dataConTyCon dc@ application.- y <- mkPmId ty- -- Newtypes don't have existentials (yet?!), so passing an empty list as- -- ex_tvs.- pure (y, PmConCt y (PmAltConLike (RealDataCon dc)) [] [x])-- build_newtypes :: Id -> [(Type, DataCon, Type)] -> DsM (Id, [PmCt])- build_newtypes x = foldrM (\dc (x, cts) -> go dc x cts) (x, [])- where- go dc x cts = second (:cts) <$> build_newtype dc x-- -- Inhabitation candidates, using the result of pmTopNormaliseType- alts_to_check :: Type -> Type -> [(Type, DataCon, Type)]- -> DsM (Either Type (TyCon, Id, [InhabitationCandidate]))- alts_to_check src_ty core_ty dcs = case splitTyConApp_maybe core_ty of- Just (tc, _)- | isTyConTriviallyInhabited tc- -> case dcs of- [] -> return (Left src_ty)- (_:_) -> do inner <- mkPmId core_ty- (outer, new_tm_cts) <- build_newtypes inner dcs- return $ Right (tc, outer, [InhabitationCandidate- { ic_cs = listToBag new_tm_cts- , ic_strict_arg_tys = [] }])-- | pmIsClosedType core_ty && not (isAbstractTyCon tc)- -- Don't consider abstract tycons since we don't know what their- -- constructors are, which makes the results of coverage checking- -- them extremely misleading.- -> do- inner <- mkPmId core_ty -- it would be wrong to unify inner- alts <- mapM (mkInhabitationCandidate inner) (tyConDataCons tc)- (outer, new_cts) <- build_newtypes inner dcs- let wrap_dcs alt = alt{ ic_cs = listToBag new_cts `unionBags` ic_cs alt}- return $ Right (tc, outer, map wrap_dcs alts)- -- For other types conservatively assume that they are inhabited.- _other -> return (Left src_ty)---- | All these types are trivially inhabited-triviallyInhabitedTyCons :: UniqSet TyCon-triviallyInhabitedTyCons = mkUniqSet [- charTyCon, doubleTyCon, floatTyCon, intTyCon, wordTyCon, word8TyCon- ]--isTyConTriviallyInhabited :: TyCon -> Bool-isTyConTriviallyInhabited tc = elementOfUniqSet tc triviallyInhabitedTyCons--------------------------------- * Detecting vacuous types--{- Note [Checking EmptyCase Expressions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Empty case expressions are strict on the scrutinee. That is, `case x of {}`-will force argument `x`. Hence, `checkMatches` is not sufficient for checking-empty cases, because it assumes that the match is not strict (which is true-for all other cases, apart from EmptyCase). This gave rise to #10746. Instead,-we do the following:--1. We normalise the outermost type family redex, data family redex or newtype,- using pmTopNormaliseType (in "GHC.Core.FamInstEnv"). This computes 3- things:- (a) A normalised type src_ty, which is equal to the type of the scrutinee in- source Haskell (does not normalise newtypes or data families)- (b) The actual normalised type core_ty, which coincides with the result- topNormaliseType_maybe. This type is not necessarily equal to the input- type in source Haskell. And this is precicely the reason we compute (a)- and (c): the reasoning happens with the underlying types, but both the- patterns and types we print should respect newtypes and also show the- family type constructors and not the representation constructors.-- (c) A list of all newtype data constructors dcs, each one corresponding to a- newtype rewrite performed in (b).-- For an example see also Note [Type normalisation]- in "GHC.Core.FamInstEnv".--2. Function Check.checkEmptyCase' performs the check:- - If core_ty is not an algebraic type, then we cannot check for- inhabitation, so we emit (_ :: src_ty) as missing, conservatively assuming- that the type is inhabited.- - If core_ty is an algebraic type, then we unfold the scrutinee to all- possible constructor patterns, using inhabitationCandidates, and then- check each one for constraint satisfiability, same as we do for normal- pattern match checking.--}---- | A 'SatisfiabilityCheck' based on "NonVoid ty" constraints, e.g. Will--- check if the @strict_arg_tys@ are actually all inhabited.--- Returns the old 'Delta' if all the types are non-void according to 'Delta'.-tysAreNonVoid :: RecTcChecker -> [Type] -> SatisfiabilityCheck-tysAreNonVoid rec_env strict_arg_tys = SC $ \delta -> do- all_non_void <- checkAllNonVoid rec_env delta strict_arg_tys- -- Check if each strict argument type is inhabitable- pure $ if all_non_void- then Just delta- else Nothing---- | Implements two performance optimizations, as described in--- @Note [Strict argument type constraints]@.-checkAllNonVoid :: RecTcChecker -> Delta -> [Type] -> DsM Bool-checkAllNonVoid rec_ts amb_cs strict_arg_tys = do- let definitely_inhabited = definitelyInhabitedType (delta_ty_st amb_cs)- tys_to_check <- filterOutM definitely_inhabited strict_arg_tys- -- See Note [Fuel for the inhabitation test]- let rec_max_bound | tys_to_check `lengthExceeds` 1- = 1- | otherwise- = 3- rec_ts' = setRecTcMaxBound rec_max_bound rec_ts- allM (nonVoid rec_ts' amb_cs) tys_to_check---- | Checks if a strict argument type of a conlike is inhabitable by a--- terminating value (i.e, an 'InhabitationCandidate').--- See @Note [Strict argument type constraints]@.-nonVoid- :: RecTcChecker -- ^ The per-'TyCon' recursion depth limit.- -> Delta -- ^ The ambient term/type constraints (known to be- -- satisfiable).- -> Type -- ^ The strict argument type.- -> DsM Bool -- ^ 'True' if the strict argument type might be inhabited by- -- a terminating value (i.e., an 'InhabitationCandidate').- -- 'False' if it is definitely uninhabitable by anything- -- (except bottom).-nonVoid rec_ts amb_cs strict_arg_ty = do- mb_cands <- inhabitationCandidates amb_cs strict_arg_ty- case mb_cands of- Right (tc, _, cands)- -- See Note [Fuel for the inhabitation test]- | Just rec_ts' <- checkRecTc rec_ts tc- -> anyM (cand_is_inhabitable rec_ts' amb_cs) cands- -- A strict argument type is inhabitable by a terminating value if- -- at least one InhabitationCandidate is inhabitable.- _ -> pure True- -- Either the type is trivially inhabited or we have exceeded the- -- recursion depth for some TyCon (so bail out and conservatively- -- claim the type is inhabited).- where- -- Checks if an InhabitationCandidate for a strict argument type:- --- -- (1) Has satisfiable term and type constraints.- -- (2) Has 'nonVoid' strict argument types (we bail out of this- -- check if recursion is detected).- --- -- See Note [Strict argument type constraints]- cand_is_inhabitable :: RecTcChecker -> Delta- -> InhabitationCandidate -> DsM Bool- cand_is_inhabitable rec_ts amb_cs- (InhabitationCandidate{ ic_cs = new_cs- , ic_strict_arg_tys = new_strict_arg_tys }) = do- let (new_ty_cs, new_tm_cs) = partitionTyTmCts new_cs- fmap isJust $ runSatisfiabilityCheck amb_cs $ mconcat- [ tyIsSatisfiable False (listToBag new_ty_cs)- , tmIsSatisfiable (listToBag new_tm_cs)- , tysAreNonVoid rec_ts new_strict_arg_tys- ]---- | @'definitelyInhabitedType' ty@ returns 'True' if @ty@ has at least one--- constructor @C@ such that:------ 1. @C@ has no equality constraints.--- 2. @C@ has no strict argument types.------ See the @Note [Strict argument type constraints]@.-definitelyInhabitedType :: TyState -> Type -> DsM Bool-definitelyInhabitedType ty_st ty = do- res <- pmTopNormaliseType ty_st ty- pure $ case res of- HadRedexes _ cons _ -> any meets_criteria cons- _ -> False- where- meets_criteria :: (Type, DataCon, Type) -> Bool- meets_criteria (_, con, _) =- null (dataConEqSpec con) && -- (1)- null (dataConImplBangs con) -- (2)--{- Note [Strict argument type constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In the ConVar case of clause processing, each conlike K traditionally-generates two different forms of constraints:--* A term constraint (e.g., x ~ K y1 ... yn)-* Type constraints from the conlike's context (e.g., if K has type- forall bs. Q => s1 .. sn -> T tys, then Q would be its type constraints)--As it turns out, these alone are not enough to detect a certain class of-unreachable code. Consider the following example (adapted from #15305):-- data K = K1 | K2 !Void-- f :: K -> ()- f K1 = ()--Even though `f` doesn't match on `K2`, `f` is exhaustive in its patterns. Why?-Because it's impossible to construct a terminating value of type `K` using the-`K2` constructor, and thus it's impossible for `f` to ever successfully match-on `K2`.--The reason is because `K2`'s field of type `Void` is //strict//. Because there-are no terminating values of type `Void`, any attempt to construct something-using `K2` will immediately loop infinitely or throw an exception due to the-strictness annotation. (If the field were not strict, then `f` could match on,-say, `K2 undefined` or `K2 (let x = x in x)`.)--Since neither the term nor type constraints mentioned above take strict-argument types into account, we make use of the `nonVoid` function to-determine whether a strict type is inhabitable by a terminating value or not.-We call this the "inhabitation test".--`nonVoid ty` returns True when either:-1. `ty` has at least one InhabitationCandidate for which both its term and type- constraints are satisfiable, and `nonVoid` returns `True` for all of the- strict argument types in that InhabitationCandidate.-2. We're unsure if it's inhabited by a terminating value.--`nonVoid ty` returns False when `ty` is definitely uninhabited by anything-(except bottom). Some examples:--* `nonVoid Void` returns False, since Void has no InhabitationCandidates.- (This is what lets us discard the `K2` constructor in the earlier example.)-* `nonVoid (Int :~: Int)` returns True, since it has an InhabitationCandidate- (through the Refl constructor), and its term constraint (x ~ Refl) and- type constraint (Int ~ Int) are satisfiable.-* `nonVoid (Int :~: Bool)` returns False. Although it has an- InhabitationCandidate (by way of Refl), its type constraint (Int ~ Bool) is- not satisfiable.-* Given the following definition of `MyVoid`:-- data MyVoid = MkMyVoid !Void-- `nonVoid MyVoid` returns False. The InhabitationCandidate for the MkMyVoid- constructor contains Void as a strict argument type, and since `nonVoid Void`- returns False, that InhabitationCandidate is discarded, leaving no others.-* Whether or not a type is inhabited is undecidable in general.- See Note [Fuel for the inhabitation test].-* For some types, inhabitation is evident immediately and we don't need to- perform expensive tests. See Note [Types that are definitely inhabitable].--Note [Fuel for the inhabitation test]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Whether or not a type is inhabited is undecidable in general. As a result, we-can run into infinite loops in `nonVoid`. Therefore, we adopt a fuel-based-approach to prevent that.--Consider the following example:-- data Abyss = MkAbyss !Abyss- stareIntoTheAbyss :: Abyss -> a- stareIntoTheAbyss x = case x of {}--In principle, stareIntoTheAbyss is exhaustive, since there is no way to-construct a terminating value using MkAbyss. However, both the term and type-constraints for MkAbyss are satisfiable, so the only way one could determine-that MkAbyss is unreachable is to check if `nonVoid Abyss` returns False.-There is only one InhabitationCandidate for Abyss—MkAbyss—and both its term-and type constraints are satisfiable, so we'd need to check if `nonVoid Abyss`-returns False... and now we've entered an infinite loop!--To avoid this sort of conundrum, `nonVoid` uses a simple test to detect the-presence of recursive types (through `checkRecTc`), and if recursion is-detected, we bail out and conservatively assume that the type is inhabited by-some terminating value. This avoids infinite loops at the expense of making-the coverage checker incomplete with respect to functions like-stareIntoTheAbyss above. Then again, the same problem occurs with recursive-newtypes, like in the following code:-- newtype Chasm = MkChasm Chasm- gazeIntoTheChasm :: Chasm -> a- gazeIntoTheChasm x = case x of {} -- Erroneously warned as non-exhaustive--So this limitation is somewhat understandable.--Note that even with this recursion detection, there is still a possibility that-`nonVoid` can run in exponential time. Consider the following data type:-- data T = MkT !T !T !T--If we call `nonVoid` on each of its fields, that will require us to once again-check if `MkT` is inhabitable in each of those three fields, which in turn will-require us to check if `MkT` is inhabitable again... As you can see, the-branching factor adds up quickly, and if the recursion depth limit is, say,-100, then `nonVoid T` will effectively take forever.--To mitigate this, we check the branching factor every time we are about to call-`nonVoid` on a list of strict argument types. If the branching factor exceeds 1-(i.e., if there is potential for exponential runtime), then we limit the-maximum recursion depth to 1 to mitigate the problem. If the branching factor-is exactly 1 (i.e., we have a linear chain instead of a tree), then it's okay-to stick with a larger maximum recursion depth.--In #17977 we saw that the defaultRecTcMaxBound (100 at the time of writing) was-too large and had detrimental effect on performance of the coverage checker.-Given that we only commit to a best effort anyway, we decided to substantially-decrement the recursion depth to 3, at the cost of precision in some edge cases-like-- data Nat = Z | S Nat- data Down :: Nat -> Type where- Down :: !(Down n) -> Down (S n)- f :: Down (S (S (S (S (S Z))))) -> ()- f x = case x of {}--Since the coverage won't bother to instantiate Down 4 levels deep to see that it-is in fact uninhabited, it will emit a inexhaustivity warning for the case.--Note [Types that are definitely inhabitable]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Another microoptimization applies to data types like this one:-- data S a = S ![a] !T--Even though there is a strict field of type [a], it's quite silly to call-nonVoid on it, since it's "obvious" that it is inhabitable. To make this-intuition formal, we say that a type is definitely inhabitable (DI) if:-- * It has at least one constructor C such that:- 1. C has no equality constraints (since they might be unsatisfiable)- 2. C has no strict argument types (since they might be uninhabitable)--It's relatively cheap to check if a type is DI, so before we call `nonVoid`-on a list of strict argument types, we filter out all of the DI ones.--}------------------------------------------------- * Providing positive evidence for a Delta---- | @provideEvidence vs n delta@ returns a list of--- at most @n@ (but perhaps empty) refinements of @delta@ that instantiate--- @vs@ to compatible constructor applications or wildcards.--- Negative information is only retained if literals are involved or when--- for recursive GADTs.-provideEvidence :: [Id] -> Int -> Delta -> DsM [Delta]-provideEvidence = go- where- go _ 0 _ = pure []- go [] _ delta = pure [delta]- go (x:xs) n delta = do- tracePm "provideEvidence" (ppr x $$ ppr xs $$ ppr delta $$ ppr n)- VI _ pos neg _ <- initLookupVarInfo delta x- case pos of- _:_ -> do- -- All solutions must be valid at once. Try to find candidates for their- -- fields. Example:- -- f x@(Just _) True = case x of SomePatSyn _ -> ()- -- after this clause, we want to report that- -- * @f Nothing _@ is uncovered- -- * @f x False@ is uncovered- -- where @x@ will have two possibly compatible solutions, @Just y@ for- -- some @y@ and @SomePatSyn z@ for some @z@. We must find evidence for @y@- -- and @z@ that is valid at the same time. These constitute arg_vas below.- let arg_vas = concatMap (\(_cl, _tvs, args) -> args) pos- go (arg_vas ++ xs) n delta- []- -- When there are literals involved, just print negative info- -- instead of listing missed constructors- | notNull [ l | PmAltLit l <- pmAltConSetElems neg ]- -> go xs n delta- [] -> try_instantiate x xs n delta-- -- | Tries to instantiate a variable by possibly following the chain of- -- newtypes and then instantiating to all ConLikes of the wrapped type's- -- minimal residual COMPLETE set.- try_instantiate :: Id -> [Id] -> Int -> Delta -> DsM [Delta]- -- Convention: x binds the outer constructor in the chain, y the inner one.- try_instantiate x xs n delta = do- (_src_ty, dcs, core_ty) <- tntrGuts <$> pmTopNormaliseType (delta_ty_st delta) (idType x)- let build_newtype (x, delta) (_ty, dc, arg_ty) = do- y <- lift $ mkPmId arg_ty- -- Newtypes don't have existentials (yet?!), so passing an empty- -- list as ex_tvs.- delta' <- addConCt delta x (PmAltConLike (RealDataCon dc)) [] [y]- pure (y, delta')- runMaybeT (foldlM build_newtype (x, delta) dcs) >>= \case- Nothing -> pure []- Just (y, newty_delta) -> do- -- Pick a COMPLETE set and instantiate it (n at max). Take care of ⊥.- pm <- vi_cache <$> initLookupVarInfo newty_delta y- mb_cls <- pickMinimalCompleteSet newty_delta pm- case uniqDSetToList <$> mb_cls of- Just cls@(_:_) -> instantiate_cons y core_ty xs n newty_delta cls- Just [] | not (canDiverge newty_delta y) -> pure []- -- Either ⊥ is still possible (think Void) or there are no COMPLETE- -- sets available, so we can assume it's inhabited- _ -> go xs n newty_delta-- instantiate_cons :: Id -> Type -> [Id] -> Int -> Delta -> [ConLike] -> DsM [Delta]- instantiate_cons _ _ _ _ _ [] = pure []- instantiate_cons _ _ _ 0 _ _ = pure []- instantiate_cons _ ty xs n delta _- -- We don't want to expose users to GHC-specific constructors for Int etc.- | fmap (isTyConTriviallyInhabited . fst) (splitTyConApp_maybe ty) == Just True- = go xs n delta- instantiate_cons x ty xs n delta (cl:cls) = do- env <- dsGetFamInstEnvs- case guessConLikeUnivTyArgsFromResTy env ty cl of- Nothing -> pure [delta] -- No idea how to refine this one, so just finish off with a wildcard- Just arg_tys -> do- (tvs, arg_vars, new_ty_cs, strict_arg_tys) <- mkOneConFull arg_tys cl- let new_tm_cs = unitBag (TmConCt x (PmAltConLike cl) tvs arg_vars)- -- Now check satifiability- mb_delta <- pmIsSatisfiable delta new_ty_cs new_tm_cs strict_arg_tys- tracePm "instantiate_cons" (vcat [ ppr x- , ppr (idType x)- , ppr ty- , ppr cl- , ppr arg_tys- , ppr new_tm_cs- , ppr new_ty_cs- , ppr strict_arg_tys- , ppr delta- , ppr mb_delta- , ppr n ])- con_deltas <- case mb_delta of- Nothing -> pure []- -- NB: We don't prepend arg_vars as we don't have any evidence on- -- them and we only want to split once on a data type. They are- -- inhabited, otherwise pmIsSatisfiable would have refuted.- Just delta' -> go xs n delta'- other_cons_deltas <- instantiate_cons x ty xs (n - length con_deltas) delta cls- pure (con_deltas ++ other_cons_deltas)--pickMinimalCompleteSet :: Delta -> PossibleMatches -> DsM (Maybe ConLikeSet)-pickMinimalCompleteSet _ NoPM = pure Nothing--- TODO: First prune sets with type info in delta. But this is good enough for--- now and less costly. See #17386.-pickMinimalCompleteSet _ (PM clss) = do- tracePm "pickMinimalCompleteSet" (ppr $ NonEmpty.toList clss)- pure (Just (minimumBy (comparing sizeUniqDSet) clss))---- | Finds a representant of the semantic equality class of the given @e@.--- Which is the @x@ of a @let x = e'@ constraint (with @e@ semantically--- equivalent to @e'@) we encountered earlier, or a fresh identifier if--- there weren't any such constraints.-representCoreExpr :: Delta -> CoreExpr -> DsM (Delta, Id)-representCoreExpr delta@MkDelta{ delta_tm_st = ts@TmSt{ ts_reps = reps } } e- | Just rep <- lookupCoreMap reps e = pure (delta, rep)- | otherwise = do- rep <- mkPmId (exprType e)- let reps' = extendCoreMap reps e rep- let delta' = delta{ delta_tm_st = ts{ ts_reps = reps' } }- pure (delta', rep)---- | Inspects a 'PmCoreCt' @let x = e@ by recording constraints for @x@ based--- on the shape of the 'CoreExpr' @e@. Examples:------ * For @let x = Just (42, 'z')@ we want to record the--- constraints @x ~ Just a, a ~ (b, c), b ~ 42, c ~ 'z'@.--- See 'data_con_app'.--- * For @let x = unpackCString# "tmp"@ we want to record the literal--- constraint @x ~ "tmp"@.--- * For @let x = I# 42@ we want the literal constraint @x ~ 42@. Similar--- for other literals. See 'coreExprAsPmLit'.--- * Finally, if we have @let x = e@ and we already have seen @let y = e@, we--- want to record @x ~ y@.-addCoreCt :: Delta -> Id -> CoreExpr -> MaybeT DsM Delta-addCoreCt delta x e = do- dflags <- getDynFlags- let e' = simpleOptExpr dflags e- lift $ tracePm "addCoreCt" (ppr x <+> dcolon <+> ppr (idType x) $$ ppr e $$ ppr e')- execStateT (core_expr x e') delta- where- -- | Takes apart a 'CoreExpr' and tries to extract as much information about- -- literals and constructor applications as possible.- core_expr :: Id -> CoreExpr -> StateT Delta (MaybeT DsM) ()- -- TODO: Handle newtypes properly, by wrapping the expression in a DataCon- -- This is the right thing for casts involving data family instances and- -- their representation TyCon, though (which are not visible in source- -- syntax). See Note [COMPLETE sets on data families]- -- core_expr x e | pprTrace "core_expr" (ppr x $$ ppr e) False = undefined- core_expr x (Cast e _co) = core_expr x e- core_expr x (Tick _t e) = core_expr x e- core_expr x e- | Just (pmLitAsStringLit -> Just s) <- coreExprAsPmLit e- , expr_ty `eqType` stringTy- -- See Note [Representation of Strings in TmState]- = case unpackFS s of- -- We need this special case to break a loop with coreExprAsPmLit- -- Otherwise we alternate endlessly between [] and ""- [] -> data_con_app x emptyInScopeSet nilDataCon []- s' -> core_expr x (mkListExpr charTy (map mkCharExpr s'))- | Just lit <- coreExprAsPmLit e- = pm_lit x lit- | Just (in_scope, _empty_floats@[], dc, _arg_tys, args)- <- exprIsConApp_maybe in_scope_env e- = data_con_app x in_scope dc args- -- See Note [Detecting pattern synonym applications in expressions]- | Var y <- e, Nothing <- isDataConId_maybe x- -- We don't consider DataCons flexible variables- = modifyT (\delta -> addVarCt delta x y)- | otherwise- -- Any other expression. Try to find other uses of a semantically- -- equivalent expression and represent them by the same variable!- = equate_with_similar_expr x e- where- expr_ty = exprType e- expr_in_scope = mkInScopeSet (exprFreeVars e)- in_scope_env = (expr_in_scope, const NoUnfolding)- -- It's inconvenient to get hold of a global in-scope set- -- here, but it'll only be needed if exprIsConApp_maybe ends- -- up substituting inside a forall or lambda (i.e. seldom)- -- so using exprFreeVars seems fine. See MR !1647.-- -- | The @e@ in @let x = e@ had no familiar form. But we can still see if- -- see if we already encountered a constraint @let y = e'@ with @e'@- -- semantically equivalent to @e@, in which case we may add the constraint- -- @x ~ y@.- equate_with_similar_expr :: Id -> CoreExpr -> StateT Delta (MaybeT DsM) ()- equate_with_similar_expr x e = do- rep <- StateT $ \delta -> swap <$> lift (representCoreExpr delta e)- -- Note that @rep == x@ if we encountered @e@ for the first time.- modifyT (\delta -> addVarCt delta x rep)-- bind_expr :: CoreExpr -> StateT Delta (MaybeT DsM) Id- bind_expr e = do- x <- lift (lift (mkPmId (exprType e)))- core_expr x e- pure x-- -- | Look at @let x = K taus theta es@ and generate the following- -- constraints (assuming universals were dropped from @taus@ before):- -- 1. @a_1 ~ tau_1, ..., a_n ~ tau_n@ for fresh @a_i@- -- 2. @y_1 ~ e_1, ..., y_m ~ e_m@ for fresh @y_i@- -- 3. @x ~ K as ys@- data_con_app :: Id -> InScopeSet -> DataCon -> [CoreExpr] -> StateT Delta (MaybeT DsM) ()- data_con_app x in_scope dc args = do- let dc_ex_tvs = dataConExTyCoVars dc- arty = dataConSourceArity dc- (ex_ty_args, val_args) = splitAtList dc_ex_tvs args- ex_tys = map exprToType ex_ty_args- vis_args = reverse $ take arty $ reverse val_args- uniq_supply <- lift $ lift $ getUniqueSupplyM- let (_, ex_tvs) = cloneTyVarBndrs (mkEmptyTCvSubst in_scope) dc_ex_tvs uniq_supply- ty_cts = equateTys (map mkTyVarTy ex_tvs) ex_tys- -- 1. @a_1 ~ tau_1, ..., a_n ~ tau_n@ for fresh @a_i@. See also #17703- modifyT $ \delta -> MaybeT $ addPmCts delta (listToBag ty_cts)- -- 2. @y_1 ~ e_1, ..., y_m ~ e_m@ for fresh @y_i@- arg_ids <- traverse bind_expr vis_args- -- 3. @x ~ K as ys@- pm_alt_con_app x (PmAltConLike (RealDataCon dc)) ex_tvs arg_ids-- -- | Adds a literal constraint, i.e. @x ~ 42@.- pm_lit :: Id -> PmLit -> StateT Delta (MaybeT DsM) ()- pm_lit x lit = pm_alt_con_app x (PmAltLit lit) [] []-- -- | Adds the given constructor application as a solution for @x@.- pm_alt_con_app :: Id -> PmAltCon -> [TyVar] -> [Id] -> StateT Delta (MaybeT DsM) ()- pm_alt_con_app x con tvs args = modifyT $ \delta -> addConCt delta x con tvs args---- | Like 'modify', but with an effectful modifier action-modifyT :: Monad m => (s -> m s) -> StateT s m ()-modifyT f = StateT $ fmap ((,) ()) . f--{- Note [Detecting pattern synonym applications in expressions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-At the moment we fail to detect pattern synonyms in scrutinees and RHS of-guards. This could be alleviated with considerable effort and complexity, but-the returns are meager. Consider:-- pattern P- pattern Q- case P 15 of- Q _ -> ...- P 15 ->--Compared to the situation where P and Q are DataCons, the lack of generativity-means we could never flag Q as redundant. (also see Note [Undecidable Equality-for PmAltCons] in PmTypes.) On the other hand, if we fail to recognise the-pattern synonym, we flag the pattern match as inexhaustive. That wouldn't happen-if we had knowledge about the scrutinee, in which case the oracle basically-knows "If it's a P, then its field is 15".--This is a pretty narrow use case and I don't think we should to try to fix it-until a user complains energetically.--}
− compiler/GHC/HsToCore/PmCheck/Ppr.hs
@@ -1,223 +0,0 @@-{-# LANGUAGE CPP, ViewPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}---- | Provides factilities for pretty-printing 'Delta's in a way appropriate for--- user facing pattern match warnings.-module GHC.HsToCore.PmCheck.Ppr (- pprUncovered- ) where--#include "GhclibHsVersions.h"--import GHC.Prelude--import GHC.Types.Basic-import GHC.Types.Id-import GHC.Types.Var.Env-import GHC.Types.Unique.DFM-import GHC.Core.ConLike-import GHC.Core.DataCon-import GHC.Builtin.Types-import GHC.Utils.Outputable-import GHC.Utils.Panic-import Control.Monad.Trans.RWS.CPS-import GHC.Utils.Misc-import GHC.Data.Maybe-import Data.List.NonEmpty (NonEmpty, nonEmpty, toList)--import GHC.HsToCore.PmCheck.Types-import GHC.HsToCore.PmCheck.Oracle---- | Pretty-print the guts of an uncovered value vector abstraction, i.e., its--- components and refutable shapes associated to any mentioned variables.------ Example for @([Just p, q], [p :-> [3,4], q :-> [0,5]])@:------ @--- (Just p) q--- where p is not one of {3, 4}--- q is not one of {0, 5}--- @------ When the set of refutable shapes contains more than 3 elements, the--- additional elements are indicated by "...".-pprUncovered :: Delta -> [Id] -> SDoc-pprUncovered delta vas- | isNullUDFM refuts = fsep vec -- there are no refutations- | otherwise = hang (fsep vec) 4 $- text "where" <+> vcat (map (pprRefutableShapes . snd) (udfmToList refuts))- where- init_prec- -- No outer parentheses when it's a unary pattern by assuming lowest- -- precedence- | [_] <- vas = topPrec- | otherwise = appPrec- ppr_action = mapM (pprPmVar init_prec) vas- (vec, renamings) = runPmPpr delta ppr_action- refuts = prettifyRefuts delta renamings---- | Output refutable shapes of a variable in the form of @var is not one of {2,--- Nothing, 3}@. Will never print more than 3 refutable shapes, the tail is--- indicated by an ellipsis.-pprRefutableShapes :: (SDoc,[PmAltCon]) -> SDoc-pprRefutableShapes (var, alts)- = var <+> text "is not one of" <+> format_alts alts- where- format_alts = braces . fsep . punctuate comma . shorten . map ppr_alt- shorten (a:b:c:_:_) = a:b:c:[text "..."]- shorten xs = xs- ppr_alt (PmAltConLike cl) = ppr cl- ppr_alt (PmAltLit lit) = ppr lit--{- 1. Literals-~~~~~~~~~~~~~~-Starting with a function definition like:-- f :: Int -> Bool- f 5 = True- f 6 = True--The uncovered set looks like:- { var |> var /= 5, var /= 6 }--Yet, we would like to print this nicely as follows:- x , where x not one of {5,6}--Since these variables will be shown to the programmer, we give them better names-(t1, t2, ..) in 'prettifyRefuts', hence the SDoc in 'PrettyPmRefutEnv'.--2. Residual Constraints-~~~~~~~~~~~~~~~~~~~~~~~-Unhandled constraints that refer to HsExpr are typically ignored by the solver-(it does not even substitute in HsExpr so they are even printed as wildcards).-Additionally, the oracle returns a substitution if it succeeds so we apply this-substitution to the vectors before printing them out (see function `pprOne' in-"GHC.HsToCore.PmCheck") to be more precise.--}---- | Extract and assigns pretty names to constraint variables with refutable--- shapes.-prettifyRefuts :: Delta -> DIdEnv SDoc -> DIdEnv (SDoc, [PmAltCon])-prettifyRefuts delta = listToUDFM_Directly . map attach_refuts . udfmToList- where- attach_refuts (u, sdoc) = (u, (sdoc, lookupRefuts delta u))---type PmPprM a = RWS Delta () (DIdEnv SDoc, [SDoc]) a---- Try nice names p,q,r,s,t before using the (ugly) t_i-nameList :: [SDoc]-nameList = map text ["p","q","r","s","t"] ++- [ text ('t':show u) | u <- [(0 :: Int)..] ]--runPmPpr :: Delta -> PmPprM a -> (a, DIdEnv SDoc)-runPmPpr delta m = case runRWS m delta (emptyDVarEnv, nameList) of- (a, (renamings, _), _) -> (a, renamings)---- | Allocates a new, clean name for the given 'Id' if it doesn't already have--- one.-getCleanName :: Id -> PmPprM SDoc-getCleanName x = do- (renamings, name_supply) <- get- let (clean_name:name_supply') = name_supply- case lookupDVarEnv renamings x of- Just nm -> pure nm- Nothing -> do- put (extendDVarEnv renamings x clean_name, name_supply')- pure clean_name--checkRefuts :: Id -> PmPprM (Maybe SDoc) -- the clean name if it has negative info attached-checkRefuts x = do- delta <- ask- case lookupRefuts delta x of- [] -> pure Nothing -- Will just be a wildcard later on- _ -> Just <$> getCleanName x---- | Pretty print a variable, but remember to prettify the names of the variables--- that refer to neg-literals. The ones that cannot be shown are printed as--- underscores. Even with a type signature, if it's not too noisy.-pprPmVar :: PprPrec -> Id -> PmPprM SDoc--- Type signature is "too noisy" by my definition if it needs to parenthesize.--- I like "not matched: _ :: Proxy (DIdEnv SDoc)",--- but I don't like "not matched: (_ :: stuff) (_:_) (_ :: Proxy (DIdEnv SDoc))"--- The useful information in the latter case is the constructor that we missed,--- not the types of the wildcards in the places that aren't matched as a result.-pprPmVar prec x = do- delta <- ask- case lookupSolution delta x of- Just (alt, _tvs, args) -> pprPmAltCon prec alt args- Nothing -> fromMaybe typed_wildcard <$> checkRefuts x- where- -- if we have no info about the parameter and would just print a- -- wildcard, also show its type.- typed_wildcard- | prec <= sigPrec- = underscore <+> text "::" <+> ppr (idType x)- | otherwise- = underscore--pprPmAltCon :: PprPrec -> PmAltCon -> [Id] -> PmPprM SDoc-pprPmAltCon _prec (PmAltLit l) _ = pure (ppr l)-pprPmAltCon prec (PmAltConLike cl) args = do- delta <- ask- pprConLike delta prec cl args--pprConLike :: Delta -> PprPrec -> ConLike -> [Id] -> PmPprM SDoc-pprConLike delta _prec cl args- | Just pm_expr_list <- pmExprAsList delta (PmAltConLike cl) args- = case pm_expr_list of- NilTerminated list ->- brackets . fsep . punctuate comma <$> mapM (pprPmVar appPrec) list- WcVarTerminated pref x ->- parens . fcat . punctuate colon <$> mapM (pprPmVar appPrec) (toList pref ++ [x])-pprConLike _delta _prec (RealDataCon con) args- | isUnboxedTupleCon con- , let hash_parens doc = text "(#" <+> doc <+> text "#)"- = hash_parens . fsep . punctuate comma <$> mapM (pprPmVar appPrec) args- | isTupleDataCon con- = parens . fsep . punctuate comma <$> mapM (pprPmVar appPrec) args-pprConLike _delta prec cl args- | conLikeIsInfix cl = case args of- [x, y] -> do x' <- pprPmVar funPrec x- y' <- pprPmVar funPrec y- return (cparen (prec > opPrec) (x' <+> ppr cl <+> y'))- -- can it be infix but have more than two arguments?- list -> pprPanic "pprConLike:" (ppr list)- | null args = return (ppr cl)- | otherwise = do args' <- mapM (pprPmVar appPrec) args- return (cparen (prec > funPrec) (fsep (ppr cl : args')))---- | The result of 'pmExprAsList'.-data PmExprList- = NilTerminated [Id]- | WcVarTerminated (NonEmpty Id) Id---- | Extract a list of 'Id's out of a sequence of cons cells, optionally--- terminated by a wildcard variable instead of @[]@. Some examples:------ * @pmExprAsList (1:2:[]) == Just ('NilTerminated' [1,2])@, a regular,--- @[]@-terminated list. Should be pretty-printed as @[1,2]@.--- * @pmExprAsList (1:2:x) == Just ('WcVarTerminated' [1,2] x)@, a list prefix--- ending in a wildcard variable x (of list type). Should be pretty-printed as--- (1:2:_).--- * @pmExprAsList [] == Just ('NilTerminated' [])@-pmExprAsList :: Delta -> PmAltCon -> [Id] -> Maybe PmExprList-pmExprAsList delta = go_con []- where- go_var rev_pref x- | Just (alt, _tvs, args) <- lookupSolution delta x- = go_con rev_pref alt args- go_var rev_pref x- | Just pref <- nonEmpty (reverse rev_pref)- = Just (WcVarTerminated pref x)- go_var _ _- = Nothing-- go_con rev_pref (PmAltConLike (RealDataCon c)) es- | c == nilDataCon- = ASSERT( null es ) Just (NilTerminated (reverse rev_pref))- | c == consDataCon- = ASSERT( length es == 2 ) go_var (es !! 0 : rev_pref) (es !! 1)- go_con _ _ _- = Nothing
+ compiler/GHC/HsToCore/Pmc.hs view
@@ -0,0 +1,516 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE FlexibleInstances #-}++-- | This module coverage checks pattern matches. It finds+--+-- * Uncovered patterns, certifying non-exhaustivity+-- * Redundant equations+-- * Equations with an inaccessible right-hand-side+--+-- The algorithm is based on the paper+-- [Lower Your Guards: A Compositional Pattern-Match Coverage Checker"](https://dl.acm.org/doi/abs/10.1145/3408989)+--+-- There is an overview Figure 2 in there that's probably helpful.+-- Here is an overview of how it's implemented, which follows the structure of+-- the entry points such as 'pmcMatches':+--+-- 1. Desugar source syntax (like 'LMatch') to guard tree variants (like+-- 'GrdMatch'), with one of the desugaring functions (like 'desugarMatch').+-- See "GHC.HsToCore.Pmc.Desugar".+-- Follows Section 3.1 in the paper.+-- 2. Coverage check guard trees (with a function like 'checkMatch') to get a+-- 'CheckResult'. See "GHC.HsToCore.Pmc.Check".+-- The normalised refinement types 'Nabla' are tested for inhabitants by+-- "GHC.HsToCore.Pmc.Solver".+-- 3. Collect redundancy information into a 'CIRB' with a function such+-- as 'cirbsMatch'. Follows the R function from Figure 6 of the paper.+-- 4. Format and report uncovered patterns and redundant equations ('CIRB')+-- with 'formatReportWarnings'. Basically job of the G function, plus proper+-- pretty printing of the warnings (Section 5.4 of the paper).+-- 5. Return 'Nablas' reaching syntactic sub-components for+-- Note [Long-distance information]. Collected by functions such as+-- 'ldiMatch'. See Section 4.1 of the paper.+module GHC.HsToCore.Pmc (+ -- Checking and printing+ pmcPatBind, pmcMatches, pmcGRHSs,+ isMatchContextPmChecked,++ -- See Note [Long-distance information]+ addTyCs, addCoreScrutTmCs, addHsScrutTmCs+ ) where++#include "GhclibHsVersions.h"++import GHC.Prelude++import GHC.HsToCore.Pmc.Types+import GHC.HsToCore.Pmc.Utils+import GHC.HsToCore.Pmc.Desugar+import GHC.HsToCore.Pmc.Check+import GHC.HsToCore.Pmc.Solver+import GHC.HsToCore.Pmc.Ppr+import GHC.Types.Basic (Origin(..))+import GHC.Core (CoreExpr)+import GHC.Driver.Session+import GHC.Driver.Types+import GHC.Hs+import GHC.Types.Id+import GHC.Types.SrcLoc+import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Types.Var (EvVar)+import GHC.Tc.Types+import GHC.Tc.Utils.TcType (evVarPred)+import {-# SOURCE #-} GHC.HsToCore.Expr (dsLExpr)+import GHC.HsToCore.Monad+import GHC.Data.Bag+import GHC.Data.IOEnv (updEnv, unsafeInterleaveM)+import GHC.Data.OrdList+import GHC.Utils.Monad (mapMaybeM)++import Control.Monad (when, forM_)+import qualified Data.Semigroup as Semi+import Data.List.NonEmpty ( NonEmpty(..) )+import qualified Data.List.NonEmpty as NE+import Data.Coerce++--+-- * Exported entry points to the checker+--++-- | A non-empty delta that is initialised from the ambient refinement type+-- capturing long-distance information, or the trivially habitable 'Nablas' if+-- the former is uninhabited.+-- See Note [Recovering from unsatisfiable pattern-matching constraints].+getLdiNablas :: DsM Nablas+getLdiNablas = do+ nablas <- getPmNablas+ isInhabited nablas >>= \case+ True -> pure nablas+ False -> pure initNablas++-- | We need to call the Hs desugarer to get the Core of a let-binding or where+-- clause. We don't want to run the coverage checker when doing so! Efficiency+-- is one concern, but also a lack of properly set up long-distance information+-- might trigger warnings that we normally wouldn't emit.+noCheckDs :: DsM a -> DsM a+noCheckDs k = do+ dflags <- getDynFlags+ let dflags' = foldl' wopt_unset dflags allPmCheckWarnings+ updEnv (\env -> env{env_top = (env_top env) {hsc_dflags = dflags'} }) k++-- | Check a pattern binding (let, where) for exhaustiveness.+pmcPatBind :: DsMatchContext -> Id -> Pat GhcTc -> DsM ()+-- See Note [pmcPatBind only checks PatBindRhs]+pmcPatBind ctxt@(DsMatchContext PatBindRhs loc) var p = do+ !missing <- getLdiNablas+ pat_bind <- noCheckDs $ desugarPatBind loc var p+ tracePm "pmcPatBind {" (vcat [ppr ctxt, ppr var, ppr p, ppr pat_bind, ppr missing])+ result <- unCA (checkPatBind pat_bind) missing+ tracePm "}: " (ppr (cr_uncov result))+ formatReportWarnings cirbsPatBind ctxt [var] result+pmcPatBind _ _ _ = pure ()++-- | Exhaustive for guard matches, is used for guards in pattern bindings and+-- in @MultiIf@ expressions. Returns the 'Nablas' covered by the RHSs.+pmcGRHSs+ :: HsMatchContext GhcRn -- ^ Match context, for warning messages+ -> GRHSs GhcTc (LHsExpr GhcTc) -- ^ The GRHSs to check+ -> DsM (NonEmpty Nablas) -- ^ Covered 'Nablas' for each RHS, for long+ -- distance info+pmcGRHSs hs_ctxt guards@(GRHSs _ grhss _) = do+ let combined_loc = foldl1 combineSrcSpans (map getLoc grhss)+ ctxt = DsMatchContext hs_ctxt combined_loc+ !missing <- getLdiNablas+ matches <- noCheckDs $ desugarGRHSs combined_loc empty guards+ tracePm "pmcGRHSs" (hang (vcat [ppr ctxt+ , text "Guards:"])+ 2+ (pprGRHSs hs_ctxt guards $$ ppr missing))+ result <- unCA (checkGRHSs matches) missing+ tracePm "}: " (ppr (cr_uncov result))+ formatReportWarnings cirbsGRHSs ctxt [] result+ return (ldiGRHSs (cr_ret result))++-- | Check a list of syntactic 'Match'es (part of case, functions, etc.), each+-- with a 'Pat' and one or more 'GRHSs':+--+-- @+-- f x y | x == y = 1 -- match on x and y with two guarded RHSs+-- | otherwise = 2+-- f _ _ = 3 -- clause with a single, un-guarded RHS+-- @+--+-- Returns one non-empty 'Nablas' for 1.) each pattern of a 'Match' and 2.)+-- each of a 'Match'es 'GRHS' for Note [Long-distance information].+--+-- Special case: When there are /no matches/, then the functionassumes it+-- checks and @-XEmptyCase@ with only a single match variable.+-- See Note [Checking EmptyCase].+pmcMatches+ :: DsMatchContext -- ^ Match context, for warnings messages+ -> [Id] -- ^ Match variables, i.e. x and y above+ -> [LMatch GhcTc (LHsExpr GhcTc)] -- ^ List of matches+ -> DsM [(Nablas, NonEmpty Nablas)] -- ^ One covered 'Nablas' per Match and+ -- GRHS, for long distance info.+pmcMatches ctxt vars matches = do+ -- We have to force @missing@ before printing out the trace message,+ -- otherwise we get interleaved output from the solver. This function+ -- should be strict in @missing@ anyway!+ !missing <- getLdiNablas+ tracePm "pmcMatches {" $+ hang (vcat [ppr ctxt, ppr vars, text "Matches:"])+ 2+ (vcat (map ppr matches) $$ ppr missing)+ case NE.nonEmpty matches of+ Nothing -> do+ -- This must be an -XEmptyCase. See Note [Checking EmptyCase]+ let var = only vars+ empty_case <- noCheckDs $ desugarEmptyCase var+ result <- unCA (checkEmptyCase empty_case) missing+ tracePm "}: " (ppr (cr_uncov result))+ formatReportWarnings cirbsEmptyCase ctxt vars result+ return []+ Just matches -> do+ matches <- noCheckDs $ desugarMatches vars matches+ result <- unCA (checkMatchGroup matches) missing+ tracePm "}: " (ppr (cr_uncov result))+ formatReportWarnings cirbsMatchGroup ctxt vars result+ return (NE.toList (ldiMatchGroup (cr_ret result)))++{- Note [pmcPatBind only checks PatBindRhs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+@pmcPatBind@'s sole purpose is to check vanilla pattern bindings, like+@x :: Int; Just x = e@, which is in a @PatBindRhs@ context.+But its caller is also called for individual pattern guards in a @StmtCtxt@.+For example, both pattern guards in @f x y | True <- x, False <- y = ...@ will+go through this function. It makes no sense to do coverage checking there:+ * Pattern guards may well fail. Fall-through is not an unrecoverable panic,+ but rather behavior the programmer expects, so inexhaustivity should not be+ reported.+ * Redundancy is already reported for the whole GRHS via one of the other+ exported coverage checking functions. Also reporting individual redundant+ guards is... redundant. See #17646.+Note that we can't just omit checking of @StmtCtxt@ altogether (by adjusting+'isMatchContextPmChecked'), because that affects the other checking functions,+too.+-}++--+-- * Collecting long-distance information+--++ldiMatchGroup :: PmMatchGroup Post -> NonEmpty (Nablas, NonEmpty Nablas)+ldiMatchGroup (PmMatchGroup matches) = ldiMatch <$> matches++ldiMatch :: PmMatch Post -> (Nablas, NonEmpty Nablas)+ldiMatch (PmMatch { pm_pats = red, pm_grhss = grhss }) =+ (rs_cov red, ldiGRHSs grhss)++ldiGRHSs :: PmGRHSs Post -> NonEmpty Nablas+ldiGRHSs (PmGRHSs { pgs_grhss = grhss }) = ldiGRHS <$> grhss++ldiGRHS :: PmGRHS Post -> Nablas+ldiGRHS (PmGRHS { pg_grds = red }) = rs_cov red++--+-- * Collecting redundancy information+--++-- | The result of redundancy checking:+-- * RHSs classified as /C/overed, /I/naccessible and /R/edundant+-- * And redundant /B/ang patterns. See Note [Dead bang patterns].+data CIRB+ = CIRB+ { cirb_cov :: !(OrdList SrcInfo) -- ^ Covered clauses+ , cirb_inacc :: !(OrdList SrcInfo) -- ^ Inaccessible clauses+ , cirb_red :: !(OrdList SrcInfo) -- ^ Redundant clauses+ , cirb_bangs :: !(OrdList SrcInfo) -- ^ Redundant bang patterns+ }++instance Semigroup CIRB where+ CIRB a b c d <> CIRB e f g h = CIRB (a <> e) (b <> f) (c <> g) (d <> h)+ where (<>) = (Semi.<>)++instance Monoid CIRB where+ mempty = CIRB mempty mempty mempty mempty++markAllRedundant :: CIRB -> CIRB+markAllRedundant CIRB { cirb_cov = cov, cirb_inacc = inacc, cirb_red = red } =+ mempty { cirb_red = cov Semi.<> inacc Semi.<> red }++-- See Note [Determining inaccessible clauses]+ensureOneNotRedundant :: CIRB -> CIRB+ensureOneNotRedundant ci = case ci of+ CIRB { cirb_cov = NilOL, cirb_inacc = NilOL, cirb_red = ConsOL r rs }+ -> ci { cirb_inacc = unitOL r, cirb_red = rs }+ _ -> ci++-- | Only adds the redundant bangs to the @CIRB@ if there is at least one+-- non-redundant 'SrcInfo'. There is no point in remembering a redundant bang+-- if the whole match is redundant!+addRedundantBangs :: OrdList SrcInfo -> CIRB -> CIRB+addRedundantBangs _red_bangs cirb@CIRB { cirb_cov = NilOL, cirb_inacc = NilOL } =+ cirb+addRedundantBangs red_bangs cirb =+ cirb { cirb_bangs = cirb_bangs cirb Semi.<> red_bangs }++-- | Checks the 'Nablas' in a 'RedSets' for inhabitants and returns+-- 1. Whether the Covered set was inhabited+-- 2. Whether the Diverging set was inhabited+-- 3. All source bangs whose 'Nablas' were empty, which means they are+-- redundant.+testRedSets :: RedSets -> DsM (Bool, Bool, OrdList SrcInfo)+testRedSets RedSets { rs_cov = cov, rs_div = div, rs_bangs = bangs } = do+ is_covered <- isInhabited cov+ may_diverge <- isInhabited div+ red_bangs <- flip mapMaybeM (fromOL bangs) $ \(nablas, bang) -> do+ isInhabited nablas >>= \case+ True -> pure Nothing+ False -> pure (Just bang)+ pure (is_covered, may_diverge, toOL red_bangs)++cirbsMatchGroup :: PmMatchGroup Post -> DsM CIRB+cirbsMatchGroup (PmMatchGroup matches) =+ Semi.sconcat <$> traverse cirbsMatch matches++cirbsMatch :: PmMatch Post -> DsM CIRB+cirbsMatch PmMatch { pm_pats = red, pm_grhss = grhss } = do+ (is_covered, may_diverge, red_bangs) <- testRedSets red+ cirb <- cirbsGRHSs grhss+ pure $ addRedundantBangs red_bangs+ -- See Note [Determining inaccessible clauses]+ $ applyWhen may_diverge ensureOneNotRedundant+ $ applyWhen (not is_covered) markAllRedundant+ $ cirb++cirbsGRHSs :: PmGRHSs Post -> DsM CIRB+cirbsGRHSs (PmGRHSs { pgs_grhss = grhss }) = Semi.sconcat <$> traverse cirbsGRHS grhss++cirbsGRHS :: PmGRHS Post -> DsM CIRB+cirbsGRHS PmGRHS { pg_grds = red, pg_rhs = info } = do+ (is_covered, may_diverge, red_bangs) <- testRedSets red+ let cirb | is_covered = mempty { cirb_cov = unitOL info }+ | may_diverge = mempty { cirb_inacc = unitOL info }+ | otherwise = mempty { cirb_red = unitOL info }+ pure (addRedundantBangs red_bangs cirb)++cirbsEmptyCase :: PmEmptyCase -> DsM CIRB+cirbsEmptyCase _ = pure mempty++cirbsPatBind :: PmPatBind Post -> DsM CIRB+cirbsPatBind = coerce cirbsGRHS++{- Note [Determining inaccessible clauses]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+ f _ True = ()+ f () True = ()+ f _ _ = ()+Is f's second clause redundant? The perhaps surprising answer is, no, it isn't!+@f (error "boom") False@ will force the error with clause 2, but will return+() if it was deleted, so clearly not redundant. Yet for now combination of+arguments we can ever reach clause 2's RHS, so we say it has inaccessible RHS+(as opposed to being completely redundant).++We detect an inaccessible RHS simply by pretending it's redundant, until we see+-}++--+-- * Formatting and reporting warnings+--++-- | Given a function that collects 'CIRB's, this function will emit warnings+-- for a 'CheckResult'.+formatReportWarnings :: (ann -> DsM CIRB) -> DsMatchContext -> [Id] -> CheckResult ann -> DsM ()+formatReportWarnings collect ctx vars cr@CheckResult { cr_ret = ann } = do+ cov_info <- collect ann+ dflags <- getDynFlags+ reportWarnings dflags ctx vars cr{cr_ret=cov_info}++-- | Issue all the warnings+-- (redundancy, inaccessibility, exhaustiveness, redundant bangs).+reportWarnings :: DynFlags -> DsMatchContext -> [Id] -> CheckResult CIRB -> DsM ()+reportWarnings dflags ctx@(DsMatchContext kind loc) vars+ CheckResult { cr_ret = CIRB { cirb_inacc = inaccessible_rhss+ , cirb_red = redundant_rhss+ , cirb_bangs = redundant_bangs }+ , cr_uncov = uncovered+ , cr_approx = precision }+ = when (flag_i || flag_u || flag_b) $ do+ unc_examples <- getNFirstUncovered vars (maxPatterns + 1) uncovered+ let exists_r = flag_i && notNull redundant_rhss+ exists_i = flag_i && notNull inaccessible_rhss+ exists_u = flag_u && notNull unc_examples+ exists_b = flag_b && notNull redundant_bangs+ approx = precision == Approximate++ when (approx && (exists_u || exists_i)) $+ putSrcSpanDs loc (warnDs NoReason approx_msg)++ when exists_b $ forM_ redundant_bangs $ \(SrcInfo (L l q)) -> do+ putSrcSpanDs l (warnDs (Reason Opt_WarnRedundantBangPatterns)+ (pprEqn q "has redundant bang"))++ when exists_r $ forM_ redundant_rhss $ \(SrcInfo (L l q)) -> do+ putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)+ (pprEqn q "is redundant"))+ when exists_i $ forM_ inaccessible_rhss $ \(SrcInfo (L l q)) -> do+ putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)+ (pprEqn q "has inaccessible right hand side"))++ when exists_u $ putSrcSpanDs loc $ warnDs flag_u_reason $+ pprEqns vars unc_examples+ where+ flag_i = overlapping dflags kind+ flag_u = exhaustive dflags kind+ flag_b = redundantBang dflags+ flag_u_reason = maybe NoReason Reason (exhaustiveWarningFlag kind)++ maxPatterns = maxUncoveredPatterns dflags++ -- Print a single clause (for redundant/with-inaccessible-rhs)+ pprEqn q txt = pprContext True ctx (text txt) $ \f ->+ f (q <+> matchSeparator kind <+> text "...")++ -- Print several clauses (for uncovered clauses)+ pprEqns vars nablas = pprContext False ctx (text "are non-exhaustive") $ \_ ->+ case vars of -- See #11245+ [] -> text "Guards do not cover entire pattern space"+ _ -> let us = map (\nabla -> pprUncovered nabla vars) nablas+ in hang (text "Patterns not matched:") 4+ (vcat (take maxPatterns us) $$ dots maxPatterns us)++ approx_msg = vcat+ [ hang+ (text "Pattern match checker ran into -fmax-pmcheck-models="+ <> int (maxPmCheckModels dflags)+ <> text " limit, so")+ 2+ ( bullet <+> text "Redundant clauses might not be reported at all"+ $$ bullet <+> text "Redundant clauses might be reported as inaccessible"+ $$ bullet <+> text "Patterns reported as unmatched might actually be matched")+ , text "Increase the limit or resolve the warnings to suppress this message." ]++getNFirstUncovered :: [Id] -> Int -> Nablas -> DsM [Nabla]+getNFirstUncovered vars n (MkNablas nablas) = go n (bagToList nablas)+ where+ go 0 _ = pure []+ go _ [] = pure []+ go n (nabla:nablas) = do+ front <- generateInhabitingPatterns vars n nabla+ back <- go (n - length front) nablas+ pure (front ++ back)++dots :: Int -> [a] -> SDoc+dots maxPatterns qs+ | qs `lengthExceeds` maxPatterns = text "..."+ | otherwise = empty++pprContext :: Bool -> DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc+pprContext singular (DsMatchContext kind _loc) msg rest_of_msg_fun+ = vcat [text txt <+> msg,+ sep [ text "In" <+> ppr_match <> char ':'+ , nest 4 (rest_of_msg_fun pref)]]+ where+ txt | singular = "Pattern match"+ | otherwise = "Pattern match(es)"++ (ppr_match, pref)+ = case kind of+ FunRhs { mc_fun = L _ fun }+ -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)+ _ -> (pprMatchContext kind, \ pp -> pp)++--+-- * Adding external long-distance information+--++-- | Locally update 'dsl_nablas' with the given action, but defer evaluation+-- with 'unsafeInterleaveM' in order not to do unnecessary work.+locallyExtendPmNablas :: (Nablas -> DsM Nablas) -> DsM a -> DsM a+locallyExtendPmNablas ext k = do+ nablas <- getLdiNablas+ nablas' <- unsafeInterleaveM $ ext nablas+ updPmNablas nablas' k++-- | Add in-scope type constraints if the coverage checker might run and then+-- run the given action.+addTyCs :: Origin -> Bag EvVar -> DsM a -> DsM a+addTyCs origin ev_vars m = do+ dflags <- getDynFlags+ applyWhen (needToRunPmCheck dflags origin)+ (locallyExtendPmNablas $ \nablas ->+ addPhiCtsNablas nablas (PhiTyCt . evVarPred <$> ev_vars))+ m++-- | Add equalities for the 'CoreExpr' scrutinee to the local 'DsM' environment+-- when checking a case expression:+-- case e of x { matches }+-- When checking matches we record that (x ~ e) where x is the initial+-- uncovered. All matches will have to satisfy this equality.+addCoreScrutTmCs :: Maybe CoreExpr -> [Id] -> DsM a -> DsM a+addCoreScrutTmCs Nothing _ k = k+addCoreScrutTmCs (Just scr) [x] k =+ flip locallyExtendPmNablas k $ \nablas ->+ addPhiCtsNablas nablas (unitBag (PhiCoreCt x scr))+addCoreScrutTmCs _ _ _ = panic "addCoreScrutTmCs: scrutinee, but more than one match id"++-- | 'addCoreScrutTmCs', but desugars the 'LHsExpr' first.+addHsScrutTmCs :: Maybe (LHsExpr GhcTc) -> [Id] -> DsM a -> DsM a+addHsScrutTmCs Nothing _ k = k+addHsScrutTmCs (Just scr) vars k = do+ scr_e <- dsLExpr scr+ addCoreScrutTmCs (Just scr_e) vars k++{- Note [Long-distance information]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++ data Color = R | G | B+ f :: Color -> Int+ f R = …+ f c = … (case c of+ G -> True+ B -> False) …++Humans can make the "long-distance connection" between the outer pattern match+and the nested case pattern match to see that the inner pattern match is+exhaustive: @c@ can't be @R@ anymore because it was matched in the first clause+of @f@.++To achieve similar reasoning in the coverage checker, we keep track of the set+of values that can reach a particular program point (often loosely referred to+as "Covered set") in 'GHC.HsToCore.Monad.dsl_nablas'.+We fill that set with Covered Nablas returned by the exported checking+functions, which the call sites put into place with+'GHC.HsToCore.Monad.updPmNablas'.+Call sites also extend this set with facts from type-constraint dictionaries,+case scrutinees, etc. with the exported functions 'addTyCs', 'addCoreScrutTmCs'+and 'addHsScrutTmCs'.++Note [Recovering from unsatisfiable pattern-matching constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following code (see #12957 and #15450):++ f :: Int ~ Bool => ()+ f = case True of { False -> () }++We want to warn that the pattern-matching in `f` is non-exhaustive. But GHC+used not to do this; in fact, it would warn that the match was /redundant/!+This is because the constraint (Int ~ Bool) in `f` is unsatisfiable, and the+coverage checker deems any matches with unsatisfiable constraint sets to be+unreachable.++We make sure to always start from an inhabited 'Nablas' by calling+'getLdiNablas', which falls back to the trivially inhabited 'Nablas' if the+long-distance info returned by 'GHC.HsToCore.Monad.getPmNablas' is empty.+-}
+ compiler/GHC/HsToCore/Pmc/Check.hs view
@@ -0,0 +1,277 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE FlexibleInstances #-}++-- | Coverage checking step of the+-- [Lower Your Guards paper](https://dl.acm.org/doi/abs/10.1145/3408989).+--+-- Coverage check guard trees (like @'PmMatch' 'Pre'@) to get a+-- 'CheckResult', containing+--+-- 1. The set of uncovered values, 'cr_uncov'+-- 2. And an annotated tree variant (like @'PmMatch' 'Post'@) that captures+-- redundancy and inaccessibility information as 'RedSets' annotations+--+-- Basically the UA function from Section 5.1, which is an optimised+-- interleaving of U and A from Section 3.2 (Figure 5).+-- The Normalised Refinement Types 'Nablas' are maintained in+-- "GHC.HsToCore.Pmc.Solver".+module GHC.HsToCore.Pmc.Check (+ CheckAction(..),+ checkMatchGroup, checkGRHSs, checkPatBind, checkEmptyCase+ ) where++#include "GhclibHsVersions.h"++import GHC.Prelude++import GHC.HsToCore.Monad ( DsM )+import GHC.HsToCore.Pmc.Types+import GHC.HsToCore.Pmc.Utils+import GHC.HsToCore.Pmc.Solver+import GHC.Driver.Session+import GHC.Utils.Outputable+import GHC.Tc.Utils.TcType (evVarPred)+import GHC.Data.OrdList++import qualified Data.Semigroup as Semi+import Data.List.NonEmpty ( NonEmpty(..) )+import qualified Data.List.NonEmpty as NE+import Data.Coerce++-- | Coverage checking action. Can be composed 'leftToRight' or 'topToBottom'.+newtype CheckAction a = CA { unCA :: Nablas -> DsM (CheckResult a) }+ deriving Functor++-- | Composes 'CheckAction's top-to-bottom:+-- If a value falls through the resulting action, then it must fall through the+-- first action and then through the second action.+-- If a value matches the resulting action, then it either matches the+-- first action or matches the second action.+-- Basically the semantics of the LYG branching construct.+topToBottom :: (top -> bot -> ret)+ -> CheckAction top+ -> CheckAction bot+ -> CheckAction ret+topToBottom f (CA top) (CA bot) = CA $ \inc -> do+ t <- top inc+ b <- bot (cr_uncov t)+ pure CheckResult { cr_ret = f (cr_ret t) (cr_ret b)+ , cr_uncov = cr_uncov b+ , cr_approx = cr_approx t Semi.<> cr_approx b }+++-- | Composes 'CheckAction's left-to-right:+-- If a value falls through the resulting action, then it either falls through the+-- first action or through the second action.+-- If a value matches the resulting action, then it must match the first action+-- and then match the second action.+-- Basically the semantics of the LYG guard construct.+leftToRight :: (RedSets -> right -> ret)+ -> CheckAction RedSets+ -> CheckAction right+ -> CheckAction ret+leftToRight f (CA left) (CA right) = CA $ \inc -> do+ l <- left inc+ r <- right (rs_cov (cr_ret l))+ limit <- maxPmCheckModels <$> getDynFlags+ let uncov = cr_uncov l Semi.<> cr_uncov r+ -- See Note [Countering exponential blowup]+ let (prec', uncov') = throttle limit inc uncov+ pure CheckResult { cr_ret = f (cr_ret l) (cr_ret r)+ , cr_uncov = uncov'+ , cr_approx = prec' Semi.<> cr_approx l Semi.<> cr_approx r }++-- | @throttle limit old new@ returns @old@ if the number of 'Nabla's in @new@+-- is exceeding the given @limit@ and the @old@ number of 'Nabla's.+-- See Note [Countering exponential blowup].+throttle :: Int -> Nablas -> Nablas -> (Precision, Nablas)+throttle limit old@(MkNablas old_ds) new@(MkNablas new_ds)+ --- | pprTrace "PmCheck:throttle" (ppr (length old_ds) <+> ppr (length new_ds) <+> ppr limit) False = undefined+ | length new_ds > max limit (length old_ds) = (Approximate, old)+ | otherwise = (Precise, new)++checkSequence :: (grdtree -> CheckAction anntree) -> NonEmpty grdtree -> CheckAction (NonEmpty anntree)+-- The implementation is pretty similar to+-- @traverse1 :: Apply f => (a -> f b) -> NonEmpty a -> f (NonEmpty b)@+checkSequence act (t :| []) = (:| []) <$> act t+checkSequence act (t1 :| (t2:ts)) =+ topToBottom (NE.<|) (act t1) (checkSequence act (t2:|ts))++emptyRedSets :: RedSets+-- Semigroup instance would be misleading!+emptyRedSets = RedSets mempty mempty mempty++checkGrd :: PmGrd -> CheckAction RedSets+checkGrd grd = CA $ \inc -> case grd of+ -- let x = e: Refine with x ~ e+ PmLet x e -> do+ matched <- addPhiCtNablas inc (PhiCoreCt x e)+ tracePm "check:Let" (ppr x <+> char '=' <+> ppr e)+ pure CheckResult { cr_ret = emptyRedSets { rs_cov = matched }+ , cr_uncov = mempty+ , cr_approx = Precise }+ -- Bang x _: Diverge on x ~ ⊥, refine with x ≁ ⊥+ PmBang x mb_info -> do+ div <- addPhiCtNablas inc (PhiBotCt x)+ matched <- addPhiCtNablas inc (PhiNotBotCt x)+ -- See Note [Dead bang patterns]+ -- mb_info = Just info <==> PmBang originates from bang pattern in source+ let bangs | Just info <- mb_info = unitOL (div, info)+ | otherwise = NilOL+ tracePm "check:Bang" (ppr x <+> ppr div)+ pure CheckResult { cr_ret = RedSets { rs_cov = matched, rs_div = div, rs_bangs = bangs }+ , cr_uncov = mempty+ , cr_approx = Precise }+ -- Con: Fall through on x ≁ K and refine with x ~ K ys and type info+ PmCon x con tvs dicts args -> do+ !div <- if isPmAltConMatchStrict con+ then addPhiCtNablas inc (PhiBotCt x)+ else pure mempty+ !matched <- addPhiCtNablas inc (PhiConCt x con tvs (map evVarPred dicts) args)+ !uncov <- addPhiCtNablas inc (PhiNotConCt x con)+ tracePm "check:Con" $ vcat+ [ ppr grd+ , ppr inc+ , hang (text "div") 2 (ppr div)+ , hang (text "matched") 2 (ppr matched)+ , hang (text "uncov") 2 (ppr uncov)+ ]+ pure CheckResult { cr_ret = emptyRedSets { rs_cov = matched, rs_div = div }+ , cr_uncov = uncov+ , cr_approx = Precise }++checkGrds :: [PmGrd] -> CheckAction RedSets+checkGrds [] = CA $ \inc ->+ pure CheckResult { cr_ret = emptyRedSets { rs_cov = inc }+ , cr_uncov = mempty+ , cr_approx = Precise }+checkGrds (g:grds) = leftToRight merge (checkGrd g) (checkGrds grds)+ where+ merge ri_g ri_grds = -- This operation would /not/ form a Semigroup!+ RedSets { rs_cov = rs_cov ri_grds+ , rs_div = rs_div ri_g Semi.<> rs_div ri_grds+ , rs_bangs = rs_bangs ri_g Semi.<> rs_bangs ri_grds }++checkMatchGroup :: PmMatchGroup Pre -> CheckAction (PmMatchGroup Post)+checkMatchGroup (PmMatchGroup matches) =+ PmMatchGroup <$> checkSequence checkMatch matches++checkMatch :: PmMatch Pre -> CheckAction (PmMatch Post)+checkMatch (PmMatch { pm_pats = GrdVec grds, pm_grhss = grhss }) =+ leftToRight PmMatch (checkGrds grds) (checkGRHSs grhss)++checkGRHSs :: PmGRHSs Pre -> CheckAction (PmGRHSs Post)+checkGRHSs (PmGRHSs { pgs_lcls = GrdVec lcls, pgs_grhss = grhss }) =+ leftToRight PmGRHSs (checkGrds lcls) (checkSequence checkGRHS grhss)++checkGRHS :: PmGRHS Pre -> CheckAction (PmGRHS Post)+checkGRHS (PmGRHS { pg_grds = GrdVec grds, pg_rhs = rhs_info }) =+ flip PmGRHS rhs_info <$> checkGrds grds++checkEmptyCase :: PmEmptyCase -> CheckAction PmEmptyCase+-- See Note [Checking EmptyCase]+checkEmptyCase pe@(PmEmptyCase { pe_var = var }) = CA $ \inc -> do+ unc <- addPhiCtNablas inc (PhiNotBotCt var)+ pure CheckResult { cr_ret = pe, cr_uncov = unc, cr_approx = mempty }++checkPatBind :: (PmPatBind Pre) -> CheckAction (PmPatBind Post)+checkPatBind = coerce checkGRHS++{- Note [Checking EmptyCase]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-XEmptyCase is useful for matching on empty data types like 'Void'. For example,+the following is a complete match:++ f :: Void -> ()+ f x = case x of {}++Really, -XEmptyCase is the only way to write a program that at the same time is+safe (@f _ = error "boom"@ is not because of ⊥), doesn't trigger a warning+(@f !_ = error "inaccessible" has inaccessible RHS) and doesn't turn an+exception into divergence (@f x = f x@).++Semantically, unlike every other case expression, -XEmptyCase is strict in its+match var x, which rules out ⊥ as an inhabitant. So we add x ≁ ⊥ to the+initial Nabla and check if there are any values left to match on.++Note [Dead bang patterns]+~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++ f :: Bool -> Int+ f True = 1+ f !x = 2++Whenever we fall through to the second equation, we will already have evaluated+the argument. Thus, the bang pattern serves no purpose and should be warned+about. We call this kind of bang patterns "dead". Dead bangs are the ones+that under no circumstances can force a thunk that wasn't already forced.+Dead bangs are a form of redundant bangs; see below.++We can detect dead bang patterns by checking whether @x ~ ⊥@ is satisfiable+where the PmBang appears in 'checkGrd'. If not, then clearly the bang is+dead. So for a source bang, we add the refined Nabla and the source info to+the 'RedSet's 'rs_bangs'. When collecting stuff to warn, we test that Nabla for+inhabitants. If it's empty, we'll warn that it's redundant.++Note that we don't want to warn for a dead bang that appears on a redundant+clause. That is because in that case, we recommend to delete the clause wholly,+including its leading pattern match.++Dead bang patterns are redundant. But there are bang patterns which are+redundant that aren't dead, for example++ f !() = 0++the bang still forces the match variable, before we attempt to match on (). But+it is redundant with the forcing done by the () match. We currently don't+detect redundant bangs that aren't dead.++Note [Countering exponential blowup]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Precise pattern match exhaustiveness checking is necessarily exponential in+the size of some input programs. We implement a counter-measure in the form of+the -fmax-pmcheck-models flag, limiting the number of Nablas we check against+each pattern by a constant.++How do we do that? Consider++ f True True = ()+ f True True = ()++And imagine we set our limit to 1 for the sake of the example. The first clause+will be checked against the initial Nabla, {}. Doing so will produce an+Uncovered set of size 2, containing the models {x≁True} and {x~True,y≁True}.+Also we find the first clause to cover the model {x~True,y~True}.++But the Uncovered set we get out of the match is too huge! We somehow have to+ensure not to make things worse as they are already, so we continue checking+with a singleton Uncovered set of the initial Nabla {}. Why is this+sound (wrt. the notion in GADTs Meet Their Match)? Well, it basically amounts+to forgetting that we matched against the first clause. The values represented+by {} are a superset of those represented by its two refinements {x≁True} and+{x~True,y≁True}.++This forgetfulness becomes very apparent in the example above: By continuing+with {} we don't detect the second clause as redundant, as it again covers the+same non-empty subset of {}. So we don't flag everything as redundant anymore,+but still will never flag something as redundant that isn't.++For exhaustivity, the converse applies: We will report @f@ as non-exhaustive+and report @f _ _@ as missing, which is a superset of the actual missing+matches. But soundness means we will never fail to report a missing match.++This mechanism is implemented in 'throttle'.++Guards are an extreme example in this regard, with #11195 being a particularly+dreadful example: Since their RHS are often pretty much unique, we split on a+variable (the one representing the RHS) that doesn't occur anywhere else in the+program, so we don't actually get useful information out of that split!+-}
+ compiler/GHC/HsToCore/Pmc/Desugar.hs view
@@ -0,0 +1,523 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE FlexibleInstances #-}++-- | Desugaring step of the+-- [Lower Your Guards paper](https://dl.acm.org/doi/abs/10.1145/3408989).+--+-- Desugars Haskell source syntax into guard tree variants Pm*.+-- In terms of the paper, this module is concerned with Sections 3.1, Figure 4,+-- in particular.+module GHC.HsToCore.Pmc.Desugar (+ desugarPatBind, desugarGRHSs, desugarMatches, desugarEmptyCase+ ) where++#include "GhclibHsVersions.h"++import GHC.Prelude++import GHC.HsToCore.Pmc.Types+import GHC.HsToCore.Pmc.Utils+import GHC.Core (Expr(Var,App))+import GHC.Data.FastString (unpackFS, lengthFS)+import GHC.Data.Bag (bagToList)+import GHC.Driver.Session+import GHC.Hs+import GHC.Tc.Utils.Zonk (shortCutLit)+import GHC.Types.Id+import GHC.Core.ConLike+import GHC.Types.Name+import GHC.Builtin.Types+import GHC.Types.SrcLoc+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc+import GHC.Core.DataCon+import GHC.Types.Var (EvVar)+import GHC.Core.Coercion+import GHC.Tc.Types.Evidence (HsWrapper(..), isIdHsWrapper)+import {-# SOURCE #-} GHC.HsToCore.Expr (dsExpr, dsLExpr, dsSyntaxExpr)+import {-# SOURCE #-} GHC.HsToCore.Binds (dsHsWrapper)+import GHC.HsToCore.Utils (selectMatchVar)+import GHC.HsToCore.Match.Literal (dsLit, dsOverLit)+import GHC.HsToCore.Monad+import GHC.Core.TyCo.Rep+import GHC.Core.Type+import GHC.HsToCore.Utils (isTrueLHsExpr)+import GHC.Data.Maybe+import qualified GHC.LanguageExtensions as LangExt+import GHC.Utils.Monad (concatMapM)++import Control.Monad (zipWithM)+import Data.List (elemIndex)+import Data.List.NonEmpty ( NonEmpty(..) )+import qualified Data.List.NonEmpty as NE++-- | Smart constructor that eliminates trivial lets+mkPmLetVar :: Id -> Id -> [PmGrd]+mkPmLetVar x y | x == y = []+mkPmLetVar x y = [PmLet x (Var y)]++-- | ADT constructor pattern => no existentials, no local constraints+vanillaConGrd :: Id -> DataCon -> [Id] -> PmGrd+vanillaConGrd scrut con arg_ids =+ PmCon { pm_id = scrut, pm_con_con = PmAltConLike (RealDataCon con)+ , pm_con_tvs = [], pm_con_dicts = [], pm_con_args = arg_ids }++-- | Creates a '[PmGrd]' refining a match var of list type to a list,+-- where list fields are matched against the incoming tagged '[PmGrd]'s.+-- For example:+-- @mkListGrds "a" "[(x, True <- x),(y, !y)]"@+-- to+-- @"[(x:b) <- a, True <- x, (y:c) <- b, !y, [] <- c]"@+-- where @b@ and @c@ are freshly allocated in @mkListGrds@ and @a@ is the match+-- variable.+mkListGrds :: Id -> [(Id, [PmGrd])] -> DsM [PmGrd]+-- See Note [Order of guards matter] for why we need to intertwine guards+-- on list elements.+mkListGrds a [] = pure [vanillaConGrd a nilDataCon []]+mkListGrds a ((x, head_grds):xs) = do+ b <- mkPmId (idType a)+ tail_grds <- mkListGrds b xs+ pure $ vanillaConGrd a consDataCon [x, b] : head_grds ++ tail_grds++-- | Create a '[PmGrd]' refining a match variable to a 'PmLit'.+mkPmLitGrds :: Id -> PmLit -> DsM [PmGrd]+mkPmLitGrds x (PmLit _ (PmLitString s)) = do+ -- We desugar String literals to list literals for better overlap reasoning.+ -- It's a little unfortunate we do this here rather than in+ -- 'GHC.HsToCore.Pmc.Solver.trySolve' and+ -- 'GHC.HsToCore.Pmc.Solver.addRefutableAltCon', but it's so much simpler+ -- here. See Note [Representation of Strings in TmState] in+ -- GHC.HsToCore.Pmc.Solver+ vars <- traverse mkPmId (take (lengthFS s) (repeat charTy))+ let mk_char_lit y c = mkPmLitGrds y (PmLit charTy (PmLitChar c))+ char_grdss <- zipWithM mk_char_lit vars (unpackFS s)+ mkListGrds x (zip vars char_grdss)+mkPmLitGrds x lit = do+ let grd = PmCon { pm_id = x+ , pm_con_con = PmAltLit lit+ , pm_con_tvs = []+ , pm_con_dicts = []+ , pm_con_args = [] }+ pure [grd]++-- | @desugarPat _ x pat@ transforms @pat@ into a '[PmGrd]', where+-- the variable representing the match is @x@.+desugarPat :: Id -> Pat GhcTc -> DsM [PmGrd]+desugarPat x pat = case pat of+ WildPat _ty -> pure []+ VarPat _ y -> pure (mkPmLetVar (unLoc y) x)+ ParPat _ p -> desugarLPat x p+ LazyPat _ _ -> pure [] -- like a wildcard+ BangPat _ p@(L l p') ->+ -- Add the bang in front of the list, because it will happen before any+ -- nested stuff.+ (PmBang x pm_loc :) <$> desugarLPat x p+ where pm_loc = Just (SrcInfo (L l (ppr p')))++ -- (x@pat) ==> Desugar pat with x as match var and handle impedance+ -- mismatch with incoming match var+ AsPat _ (L _ y) p -> (mkPmLetVar y x ++) <$> desugarLPat y p++ SigPat _ p _ty -> desugarLPat x p++ -- See Note [Desugar CoPats]+ -- Generally the translation is+ -- pat |> co ===> let y = x |> co, pat <- y where y is a match var of pat+ XPat (CoPat wrapper p _ty)+ | isIdHsWrapper wrapper -> desugarPat x p+ | WpCast co <- wrapper, isReflexiveCo co -> desugarPat x p+ | otherwise -> do+ (y, grds) <- desugarPatV p+ wrap_rhs_y <- dsHsWrapper wrapper+ pure (PmLet y (wrap_rhs_y (Var x)) : grds)++ -- (n + k) ===> let b = x >= k, True <- b, let n = x-k+ NPlusKPat _pat_ty (L _ n) k1 k2 ge minus -> do+ b <- mkPmId boolTy+ let grd_b = vanillaConGrd b trueDataCon []+ [ke1, ke2] <- traverse dsOverLit [unLoc k1, k2]+ rhs_b <- dsSyntaxExpr ge [Var x, ke1]+ rhs_n <- dsSyntaxExpr minus [Var x, ke2]+ pure [PmLet b rhs_b, grd_b, PmLet n rhs_n]++ -- (fun -> pat) ===> let y = fun x, pat <- y where y is a match var of pat+ ViewPat _arg_ty lexpr pat -> do+ (y, grds) <- desugarLPatV pat+ fun <- dsLExpr lexpr+ pure $ PmLet y (App fun (Var x)) : grds++ -- list+ ListPat (ListPatTc _elem_ty Nothing) ps ->+ desugarListPat x ps++ -- overloaded list+ ListPat (ListPatTc elem_ty (Just (pat_ty, to_list))) pats -> do+ dflags <- getDynFlags+ case splitListTyConApp_maybe pat_ty of+ Just _e_ty+ | not (xopt LangExt.RebindableSyntax dflags)+ -- Just desugar it as a regular ListPat+ -> desugarListPat x pats+ _ -> do+ y <- mkPmId (mkListTy elem_ty)+ grds <- desugarListPat y pats+ rhs_y <- dsSyntaxExpr to_list [Var x]+ pure $ PmLet y rhs_y : grds++ -- (a) In the presence of RebindableSyntax, we don't know anything about+ -- `toList`, we should treat `ListPat` as any other view pattern.+ --+ -- (b) In the absence of RebindableSyntax,+ -- - If the pat_ty is `[a]`, then we treat the overloaded list pattern+ -- as ordinary list pattern. Although we can give an instance+ -- `IsList [Int]` (more specific than the default `IsList [a]`), in+ -- practice, we almost never do that. We assume the `to_list` is+ -- the `toList` from `instance IsList [a]`.+ --+ -- - Otherwise, we treat the `ListPat` as ordinary view pattern.+ --+ -- See #14547, especially comment#9 and comment#10.++ ConPat { pat_con = L _ con+ , pat_args = ps+ , pat_con_ext = ConPatTc+ { cpt_arg_tys = arg_tys+ , cpt_tvs = ex_tvs+ , cpt_dicts = dicts+ }+ } -> do+ desugarConPatOut x con arg_tys ex_tvs dicts ps++ NPat ty (L _ olit) mb_neg _ -> do+ -- See Note [Literal short cut] in "GHC.HsToCore.Match.Literal"+ -- We inline the Literal short cut for @ty@ here, because @ty@ is more+ -- precise than the field of OverLitTc, which is all that dsOverLit (which+ -- normally does the literal short cut) can look at. Also @ty@ matches the+ -- type of the scrutinee, so info on both pattern and scrutinee (for which+ -- short cutting in dsOverLit works properly) is overloaded iff either is.+ dflags <- getDynFlags+ let platform = targetPlatform dflags+ core_expr <- case olit of+ OverLit{ ol_val = val, ol_ext = OverLitTc rebindable _ }+ | not rebindable+ , Just expr <- shortCutLit platform val ty+ -> dsExpr expr+ _ -> dsOverLit olit+ let lit = expectJust "failed to detect OverLit" (coreExprAsPmLit core_expr)+ let lit' = case mb_neg of+ Just _ -> expectJust "failed to negate lit" (negatePmLit lit)+ Nothing -> lit+ mkPmLitGrds x lit'++ LitPat _ lit -> do+ core_expr <- dsLit (convertLit lit)+ let lit = expectJust "failed to detect Lit" (coreExprAsPmLit core_expr)+ mkPmLitGrds x lit++ TuplePat _tys pats boxity -> do+ (vars, grdss) <- mapAndUnzipM desugarLPatV pats+ let tuple_con = tupleDataCon boxity (length vars)+ pure $ vanillaConGrd x tuple_con vars : concat grdss++ SumPat _ty p alt arity -> do+ (y, grds) <- desugarLPatV p+ let sum_con = sumDataCon alt arity+ -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon+ pure $ vanillaConGrd x sum_con [y] : grds++ SplicePat {} -> panic "Check.desugarPat: SplicePat"++-- | 'desugarPat', but also select and return a new match var.+desugarPatV :: Pat GhcTc -> DsM (Id, [PmGrd])+desugarPatV pat = do+ x <- selectMatchVar Many pat+ grds <- desugarPat x pat+ pure (x, grds)++desugarLPat :: Id -> LPat GhcTc -> DsM [PmGrd]+desugarLPat x = desugarPat x . unLoc++-- | 'desugarLPat', but also select and return a new match var.+desugarLPatV :: LPat GhcTc -> DsM (Id, [PmGrd])+desugarLPatV = desugarPatV . unLoc++-- | @desugarListPat _ x [p1, ..., pn]@ is basically+-- @desugarConPatOut _ x $(mkListConPatOuts [p1, ..., pn]>@ without ever+-- constructing the 'ConPatOut's.+desugarListPat :: Id -> [LPat GhcTc] -> DsM [PmGrd]+desugarListPat x pats = do+ vars_and_grdss <- traverse desugarLPatV pats+ mkListGrds x vars_and_grdss++-- | Desugar a constructor pattern+desugarConPatOut :: Id -> ConLike -> [Type] -> [TyVar]+ -> [EvVar] -> HsConPatDetails GhcTc -> DsM [PmGrd]+desugarConPatOut x con univ_tys ex_tvs dicts = \case+ PrefixCon ps -> go_field_pats (zip [0..] ps)+ InfixCon p1 p2 -> go_field_pats (zip [0..] [p1,p2])+ RecCon (HsRecFields fs _) -> go_field_pats (rec_field_ps fs)+ where+ -- The actual argument types (instantiated)+ arg_tys = map scaledThing $ conLikeInstOrigArgTys con (univ_tys ++ mkTyVarTys ex_tvs)++ -- Extract record field patterns tagged by field index from a list of+ -- LHsRecField+ rec_field_ps fs = map (tagged_pat . unLoc) fs+ where+ tagged_pat f = (lbl_to_index (getName (hsRecFieldId f)), hsRecFieldArg f)+ -- Unfortunately the label info is empty when the DataCon wasn't defined+ -- with record field labels, hence we desugar to field index.+ orig_lbls = map flSelector $ conLikeFieldLabels con+ lbl_to_index lbl = expectJust "lbl_to_index" $ elemIndex lbl orig_lbls++ go_field_pats tagged_pats = do+ -- The fields that appear might not be in the correct order. So+ -- 1. Do the PmCon match+ -- 2. Then pattern match on the fields in the order given by the first+ -- field of @tagged_pats@.+ -- See Note [Field match order for RecCon]++ -- Desugar the mentioned field patterns. We're doing this first to get+ -- the Ids for pm_con_args and bring them in order afterwards.+ let trans_pat (n, pat) = do+ (var, pvec) <- desugarLPatV pat+ pure ((n, var), pvec)+ (tagged_vars, arg_grdss) <- mapAndUnzipM trans_pat tagged_pats++ let get_pat_id n ty = case lookup n tagged_vars of+ Just var -> pure var+ Nothing -> mkPmId ty++ -- 1. the constructor pattern match itself+ arg_ids <- zipWithM get_pat_id [0..] arg_tys+ let con_grd = PmCon x (PmAltConLike con) ex_tvs dicts arg_ids++ -- 2. guards from field selector patterns+ let arg_grds = concat arg_grdss++ -- tracePm "ConPatOut" (ppr x $$ ppr con $$ ppr arg_ids)+ pure (con_grd : arg_grds)++desugarPatBind :: SrcSpan -> Id -> Pat GhcTc -> DsM (PmPatBind Pre)+-- See 'GrdPatBind' for how this simply repurposes GrdGRHS.+desugarPatBind loc var pat =+ PmPatBind . flip PmGRHS (SrcInfo (L loc (ppr pat))) . GrdVec <$> desugarPat var pat++desugarEmptyCase :: Id -> DsM PmEmptyCase+desugarEmptyCase var = pure PmEmptyCase { pe_var = var }++-- | Desugar the non-empty 'Match'es of a 'MatchGroup'.+desugarMatches :: [Id] -> NonEmpty (LMatch GhcTc (LHsExpr GhcTc))+ -> DsM (PmMatchGroup Pre)+desugarMatches vars matches =+ PmMatchGroup <$> traverse (desugarMatch vars) matches++-- Desugar a single match+desugarMatch :: [Id] -> LMatch GhcTc (LHsExpr GhcTc) -> DsM (PmMatch Pre)+desugarMatch vars (L match_loc (Match { m_pats = pats, m_grhss = grhss })) = do+ pats' <- concat <$> zipWithM desugarLPat vars pats+ grhss' <- desugarGRHSs match_loc (sep (map ppr pats)) grhss+ -- tracePm "desugarMatch" (vcat [ppr pats, ppr pats', ppr grhss'])+ return PmMatch { pm_pats = GrdVec pats', pm_grhss = grhss' }++desugarGRHSs :: SrcSpan -> SDoc -> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (PmGRHSs Pre)+desugarGRHSs match_loc pp_pats grhss = do+ lcls <- desugarLocalBinds (grhssLocalBinds grhss)+ grhss' <- traverse (desugarLGRHS match_loc pp_pats)+ . expectJust "desugarGRHSs"+ . NE.nonEmpty+ $ grhssGRHSs grhss+ return PmGRHSs { pgs_lcls = GrdVec lcls, pgs_grhss = grhss' }++-- | Desugar a guarded right-hand side to a single 'GrdTree'+desugarLGRHS :: SrcSpan -> SDoc -> LGRHS GhcTc (LHsExpr GhcTc) -> DsM (PmGRHS Pre)+desugarLGRHS match_loc pp_pats (L _loc (GRHS _ gs _)) = do+ -- _loc points to the match separator (ie =, ->) that comes after the guards.+ -- Hence we have to pass in the match_loc, which we use in case that the RHS+ -- is unguarded.+ -- pp_pats is the space-separated pattern of the current Match this+ -- GRHS belongs to, so the @A B x@ part in @A B x | 0 <- x@.+ let rhs_info = case gs of+ [] -> L match_loc pp_pats+ (L grd_loc _):_ -> L grd_loc (pp_pats <+> vbar <+> interpp'SP gs)+ grds <- concatMapM (desugarGuard . unLoc) gs+ pure PmGRHS { pg_grds = GrdVec grds, pg_rhs = SrcInfo rhs_info }++-- | Desugar a guard statement to a '[PmGrd]'+desugarGuard :: GuardStmt GhcTc -> DsM [PmGrd]+desugarGuard guard = case guard of+ BodyStmt _ e _ _ -> desugarBoolGuard e+ LetStmt _ binds -> desugarLocalBinds binds+ BindStmt _ p e -> desugarBind p e+ LastStmt {} -> panic "desugarGuard LastStmt"+ ParStmt {} -> panic "desugarGuard ParStmt"+ TransStmt {} -> panic "desugarGuard TransStmt"+ RecStmt {} -> panic "desugarGuard RecStmt"+ ApplicativeStmt {} -> panic "desugarGuard ApplicativeLastStmt"++-- | Desugar local bindings to a bunch of 'PmLet' guards.+-- Deals only with simple @let@ or @where@ bindings without any polymorphism,+-- recursion, pattern bindings etc.+-- See Note [Long-distance information for HsLocalBinds].+desugarLocalBinds :: LHsLocalBinds GhcTc -> DsM [PmGrd]+desugarLocalBinds (L _ (HsValBinds _ (XValBindsLR (NValBinds binds _)))) = do+ concatMapM (concatMapM go . bagToList) (map snd binds)+ where+ go :: LHsBind GhcTc -> DsM [PmGrd]+ go (L _ FunBind{fun_id = L _ x, fun_matches = mg})+ -- See Note [Long-distance information for HsLocalBinds] for why this+ -- pattern match is so very specific.+ | L _ [L _ Match{m_pats = [], m_grhss = grhss}] <- mg_alts mg+ , GRHSs{grhssGRHSs = [L _ (GRHS _ _grds rhs)]} <- grhss = do+ core_rhs <- dsLExpr rhs+ return [PmLet x core_rhs]+ go (L _ AbsBinds{ abs_tvs = [], abs_ev_vars = []+ , abs_exports=exports, abs_binds = binds }) = do+ -- Typechecked HsLocalBinds are wrapped in AbsBinds, which carry+ -- renamings. See Note [Long-distance information for HsLocalBinds]+ -- for the details.+ let go_export :: ABExport GhcTc -> Maybe PmGrd+ go_export ABE{abe_poly = x, abe_mono = y, abe_wrap = wrap}+ | isIdHsWrapper wrap+ = ASSERT2(idType x `eqType` idType y, ppr x $$ ppr (idType x) $$ ppr y $$ ppr (idType y))+ Just $ PmLet x (Var y)+ | otherwise+ = Nothing+ let exps = mapMaybe go_export exports+ bs <- concatMapM go (bagToList binds)+ return (exps ++ bs)+ go _ = return []+desugarLocalBinds _binds = return []++-- | Desugar a pattern guard+-- @pat <- e ==> let x = e; <guards for pat <- x>@+desugarBind :: LPat GhcTc -> LHsExpr GhcTc -> DsM [PmGrd]+desugarBind p e = dsLExpr e >>= \case+ Var y+ | Nothing <- isDataConId_maybe y+ -- RHS is a variable, so that will allow us to omit the let+ -> desugarLPat y p+ rhs -> do+ (x, grds) <- desugarLPatV p+ pure (PmLet x rhs : grds)++-- | Desugar a boolean guard+-- @e ==> let x = e; True <- x@+desugarBoolGuard :: LHsExpr GhcTc -> DsM [PmGrd]+desugarBoolGuard e+ | isJust (isTrueLHsExpr e) = return []+ -- The formal thing to do would be to generate (True <- True)+ -- but it is trivial to solve so instead we give back an empty+ -- [PmGrd] for efficiency+ | otherwise = dsLExpr e >>= \case+ Var y+ | Nothing <- isDataConId_maybe y+ -- Omit the let by matching on y+ -> pure [vanillaConGrd y trueDataCon []]+ rhs -> do+ x <- mkPmId boolTy+ pure [PmLet x rhs, vanillaConGrd x trueDataCon []]++{- Note [Field match order for RecCon]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The order for RecCon field patterns actually determines evaluation order of+the pattern match. For example:++ data T = T { a :: Char, b :: Int }+ f :: T -> ()+ f T{ b = 42, a = 'a' } = ()++Then @f (T (error "a") (error "b"))@ errors out with "b" because it is mentioned+first in the pattern match.++This means we can't just desugar the pattern match to+@[T a b <- x, 'a' <- a, 42 <- b]@. Instead we have to force them in the+right order: @[T a b <- x, 42 <- b, 'a' <- a]@.++Note [Order of guards matters]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Similar to Note [Field match order for RecCon], the order in which the guards+for a pattern match appear matter. Consider a situation similar to T5117:++ f (0:_) = ()+ f (0:[]) = ()++The latter clause is clearly redundant. Yet if we desugar the second clause as++ [x:xs' <- xs, [] <- xs', 0 <- x]++We will say that the second clause only has an inaccessible RHS. That's because+we force the tail of the list before comparing its head! So the correct+translation would have been++ [x:xs' <- xs, 0 <- x, [] <- xs']++And we have to take in the guards on list cells into @mkListGrds@.++Note [Desugar CoPats]+~~~~~~~~~~~~~~~~~~~~~~~+The pattern match checker did not know how to handle coerced patterns+`CoPat` efficiently, which gave rise to #11276. The original approach+desugared `CoPat`s:++ pat |> co ===> x (pat <- (x |> co))++Why did we do this seemingly unnecessary expansion in the first place?+The reason is that the type of @pat |> co@ (which is the type of the value+abstraction we match against) might be different than that of @pat@. Data+instances such as @Sing (a :: Bool)@ are a good example of this: If we would+just drop the coercion, we'd get a type error when matching @pat@ against its+value abstraction, with the result being that pmIsSatisfiable decides that every+possible data constructor fitting @pat@ is rejected as uninhabitated, leading to+a lot of false warnings.++But we can check whether the coercion is a hole or if it is just refl, in+which case we can drop it.++Note [Long-distance information for HsLocalBinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#18626)++ f :: Int -> ()+ f x | y = ()+ where+ y = True++ x :: ()+ x | let y = True, y = ()++Both definitions are exhaustive, but to make the necessary long-distance+connection from @y@'s binding to its use site in a guard, we have to collect+'PmLet' guards for the 'HsLocalBinds' which contain @y@'s definitions.++In principle, we are only interested in desugaring local binds that are+'FunBind's, that++ * Have no pattern matches. If @y@ above had any patterns, it would be a+ function and we can't reason about them anyway.+ * Have singleton match group with a single GRHS.+ Otherwise, what expression to pick in the generated guard @let y = <rhs>@?++It turns out that desugaring type-checked local binds in this way is a bit+more complex than expected: Apparently, all bindings are wrapped in 'AbsBinds'+Nfter type-checking. See Note [AbsBinds] in "GHC.Hs.Binds".++We make sure that there is no polymorphism in the way by checking that there+are no 'abs_tvs' or 'abs_ev_vars' (we don't reason about+@y :: forall a. Eq a => ...@) and that the exports carry no 'HsWrapper's. In+this case, the exports are a simple renaming substitution that we can capture+with 'PmLet'. Ultimately we'll hit those renamed 'FunBind's, though, which is+the whole point.++The place to store the 'PmLet' guards for @where@ clauses (which are per+'GRHSs') is as a field of 'PmGRHSs'. For plain @let@ guards as in the guards of+@x@, we can simply add them to the 'pg_grds' field of 'PmGRHS'.+-}
+ compiler/GHC/HsToCore/Pmc/Ppr.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE CPP, ViewPatterns #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++-- | Provides factilities for pretty-printing 'Nabla's in a way appropriate for+-- user facing pattern match warnings.+module GHC.HsToCore.Pmc.Ppr (+ pprUncovered+ ) where++#include "GhclibHsVersions.h"++import GHC.Prelude++import GHC.Types.Basic+import GHC.Types.Id+import GHC.Types.Var.Env+import GHC.Types.Unique.DFM+import GHC.Core.ConLike+import GHC.Core.DataCon+import GHC.Builtin.Types+import GHC.Utils.Outputable+import GHC.Utils.Panic+import Control.Monad.Trans.RWS.CPS+import GHC.Utils.Misc+import GHC.Data.Maybe+import Data.List.NonEmpty (NonEmpty, nonEmpty, toList)++import GHC.HsToCore.Pmc.Types+import GHC.HsToCore.Pmc.Solver++-- | Pretty-print the guts of an uncovered value vector abstraction, i.e., its+-- components and refutable shapes associated to any mentioned variables.+--+-- Example for @([Just p, q], [p :-> [3,4], q :-> [0,5]])@:+--+-- @+-- (Just p) q+-- where p is not one of {3, 4}+-- q is not one of {0, 5}+-- @+--+-- When the set of refutable shapes contains more than 3 elements, the+-- additional elements are indicated by "...".+pprUncovered :: Nabla -> [Id] -> SDoc+pprUncovered nabla vas+ | isNullUDFM refuts = fsep vec -- there are no refutations+ | otherwise = hang (fsep vec) 4 $+ text "where" <+> vcat (map (pprRefutableShapes . snd) (udfmToList refuts))+ where+ init_prec+ -- No outer parentheses when it's a unary pattern by assuming lowest+ -- precedence+ | [_] <- vas = topPrec+ | otherwise = appPrec+ ppr_action = mapM (pprPmVar init_prec) vas+ (vec, renamings) = runPmPpr nabla ppr_action+ refuts = prettifyRefuts nabla renamings++-- | Output refutable shapes of a variable in the form of @var is not one of {2,+-- Nothing, 3}@. Will never print more than 3 refutable shapes, the tail is+-- indicated by an ellipsis.+pprRefutableShapes :: (SDoc,[PmAltCon]) -> SDoc+pprRefutableShapes (var, alts)+ = var <+> text "is not one of" <+> format_alts alts+ where+ format_alts = braces . fsep . punctuate comma . shorten . map ppr_alt+ shorten (a:b:c:_:_) = a:b:c:[text "..."]+ shorten xs = xs+ ppr_alt (PmAltConLike cl) = ppr cl+ ppr_alt (PmAltLit lit) = ppr lit++{- 1. Literals+~~~~~~~~~~~~~~+Starting with a function definition like:++ f :: Int -> Bool+ f 5 = True+ f 6 = True++The uncovered set looks like:+ { var |> var /= 5, var /= 6 }++Yet, we would like to print this nicely as follows:+ x , where x not one of {5,6}++Since these variables will be shown to the programmer, we give them better names+(t1, t2, ..) in 'prettifyRefuts', hence the SDoc in 'PrettyPmRefutEnv'.++2. Residual Constraints+~~~~~~~~~~~~~~~~~~~~~~~+Unhandled constraints that refer to HsExpr are typically ignored by the solver+(it does not even substitute in HsExpr so they are even printed as wildcards).+Additionally, the oracle returns a substitution if it succeeds so we apply this+substitution to the vectors before printing them out (see function `pprOne' in+"GHC.HsToCore.Pmc") to be more precise.+-}++-- | Extract and assigns pretty names to constraint variables with refutable+-- shapes.+prettifyRefuts :: Nabla -> DIdEnv (Id, SDoc) -> DIdEnv (SDoc, [PmAltCon])+prettifyRefuts nabla = listToUDFM_Directly . map attach_refuts . udfmToList+ where+ attach_refuts (u, (x, sdoc)) = (u, (sdoc, lookupRefuts nabla x))+++type PmPprM a = RWS Nabla () (DIdEnv (Id, SDoc), [SDoc]) a++-- Try nice names p,q,r,s,t before using the (ugly) t_i+nameList :: [SDoc]+nameList = map text ["p","q","r","s","t"] +++ [ text ('t':show u) | u <- [(0 :: Int)..] ]++runPmPpr :: Nabla -> PmPprM a -> (a, DIdEnv (Id, SDoc))+runPmPpr nabla m = case runRWS m nabla (emptyDVarEnv, nameList) of+ (a, (renamings, _), _) -> (a, renamings)++-- | Allocates a new, clean name for the given 'Id' if it doesn't already have+-- one.+getCleanName :: Id -> PmPprM SDoc+getCleanName x = do+ (renamings, name_supply) <- get+ let (clean_name:name_supply') = name_supply+ case lookupDVarEnv renamings x of+ Just (_, nm) -> pure nm+ Nothing -> do+ put (extendDVarEnv renamings x (x, clean_name), name_supply')+ pure clean_name++checkRefuts :: Id -> PmPprM (Maybe SDoc) -- the clean name if it has negative info attached+checkRefuts x = do+ nabla <- ask+ case lookupRefuts nabla x of+ [] -> pure Nothing -- Will just be a wildcard later on+ _ -> Just <$> getCleanName x++-- | Pretty print a variable, but remember to prettify the names of the variables+-- that refer to neg-literals. The ones that cannot be shown are printed as+-- underscores. Even with a type signature, if it's not too noisy.+pprPmVar :: PprPrec -> Id -> PmPprM SDoc+-- Type signature is "too noisy" by my definition if it needs to parenthesize.+-- I like "not matched: _ :: Proxy (DIdEnv (Id, SDoc))",+-- but I don't like "not matched: (_ :: stuff) (_:_) (_ :: Proxy (DIdEnv (Id, SDoc)))"+-- The useful information in the latter case is the constructor that we missed,+-- not the types of the wildcards in the places that aren't matched as a result.+pprPmVar prec x = do+ nabla <- ask+ case lookupSolution nabla x of+ Just (PACA alt _tvs args) -> pprPmAltCon prec alt args+ Nothing -> fromMaybe typed_wildcard <$> checkRefuts x+ where+ -- if we have no info about the parameter and would just print a+ -- wildcard, also show its type.+ typed_wildcard+ | prec <= sigPrec+ = underscore <+> text "::" <+> ppr (idType x)+ | otherwise+ = underscore++pprPmAltCon :: PprPrec -> PmAltCon -> [Id] -> PmPprM SDoc+pprPmAltCon _prec (PmAltLit l) _ = pure (ppr l)+pprPmAltCon prec (PmAltConLike cl) args = do+ nabla <- ask+ pprConLike nabla prec cl args++pprConLike :: Nabla -> PprPrec -> ConLike -> [Id] -> PmPprM SDoc+pprConLike nabla _prec cl args+ | Just pm_expr_list <- pmExprAsList nabla (PmAltConLike cl) args+ = case pm_expr_list of+ NilTerminated list ->+ brackets . fsep . punctuate comma <$> mapM (pprPmVar appPrec) list+ WcVarTerminated pref x ->+ parens . fcat . punctuate colon <$> mapM (pprPmVar appPrec) (toList pref ++ [x])+pprConLike _nabla _prec (RealDataCon con) args+ | isUnboxedTupleDataCon con+ , let hash_parens doc = text "(#" <+> doc <+> text "#)"+ = hash_parens . fsep . punctuate comma <$> mapM (pprPmVar appPrec) args+ | isTupleDataCon con+ = parens . fsep . punctuate comma <$> mapM (pprPmVar appPrec) args+pprConLike _nabla prec cl args+ | conLikeIsInfix cl = case args of+ [x, y] -> do x' <- pprPmVar funPrec x+ y' <- pprPmVar funPrec y+ return (cparen (prec > opPrec) (x' <+> ppr cl <+> y'))+ -- can it be infix but have more than two arguments?+ list -> pprPanic "pprConLike:" (ppr list)+ | null args = return (ppr cl)+ | otherwise = do args' <- mapM (pprPmVar appPrec) args+ return (cparen (prec > funPrec) (fsep (ppr cl : args')))++-- | The result of 'pmExprAsList'.+data PmExprList+ = NilTerminated [Id]+ | WcVarTerminated (NonEmpty Id) Id++-- | Extract a list of 'Id's out of a sequence of cons cells, optionally+-- terminated by a wildcard variable instead of @[]@. Some examples:+--+-- * @pmExprAsList (1:2:[]) == Just ('NilTerminated' [1,2])@, a regular,+-- @[]@-terminated list. Should be pretty-printed as @[1,2]@.+-- * @pmExprAsList (1:2:x) == Just ('WcVarTerminated' [1,2] x)@, a list prefix+-- ending in a wildcard variable x (of list type). Should be pretty-printed as+-- (1:2:_).+-- * @pmExprAsList [] == Just ('NilTerminated' [])@+pmExprAsList :: Nabla -> PmAltCon -> [Id] -> Maybe PmExprList+pmExprAsList nabla = go_con []+ where+ go_var rev_pref x+ | Just (PACA alt _tvs args) <- lookupSolution nabla x+ = go_con rev_pref alt args+ go_var rev_pref x+ | Just pref <- nonEmpty (reverse rev_pref)+ = Just (WcVarTerminated pref x)+ go_var _ _+ = Nothing++ go_con rev_pref (PmAltConLike (RealDataCon c)) es+ | c == nilDataCon+ = ASSERT( null es ) Just (NilTerminated (reverse rev_pref))+ | c == consDataCon+ = ASSERT( length es == 2 ) go_var (es !! 0 : rev_pref) (es !! 1)+ go_con _ _ _+ = Nothing
+ compiler/GHC/HsToCore/Pmc/Solver.hs view
@@ -0,0 +1,1733 @@+{-+Authors: George Karachalias <george.karachalias@cs.kuleuven.be>+ Sebastian Graf <sgraf1337@gmail.com>+ Ryan Scott <ryan.gl.scott@gmail.com>+-}++{-# LANGUAGE CPP, LambdaCase, TupleSections, PatternSynonyms, ViewPatterns,+ MultiWayIf, ScopedTypeVariables, MagicHash #-}++-- | Model refinements type as per the+-- [Lower Your Guards paper](https://dl.acm.org/doi/abs/10.1145/3408989).+-- The main export of the module are the functions 'addPhiCtsNablas' for adding+-- facts to the oracle, 'isInhabited' to check if a refinement type is inhabited+-- and 'generateInhabitingPatterns' to turn a 'Nabla' into a concrete pattern+-- for an equation.+--+-- In terms of the LYG paper, this module is concerned with Sections 3.4, 3.6+-- and 3.7. E.g., it represents refinement types directly as a bunch of+-- normalised refinement types 'Nabla'.+module GHC.HsToCore.Pmc.Solver (++ Nabla, Nablas(..), initNablas,+ lookupRefuts, lookupSolution,++ PhiCt(..), PhiCts,+ addPhiCtNablas,+ addPhiCtsNablas,++ isInhabited,+ generateInhabitingPatterns++ ) where++#include "GhclibHsVersions.h"++import GHC.Prelude++import GHC.HsToCore.Pmc.Types+import GHC.HsToCore.Pmc.Utils ( tracePm, mkPmId )++import GHC.Driver.Session+import GHC.Driver.Config+import GHC.Utils.Outputable+import GHC.Utils.Error ( pprErrMsgBagWithLoc )+import GHC.Utils.Misc+import GHC.Utils.Panic+import GHC.Data.Bag+import GHC.Types.Unique.Set+import GHC.Types.Unique.DSet+import GHC.Types.Unique.SDFM+import GHC.Types.Id+import GHC.Types.Name+import GHC.Types.Var (EvVar)+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Core+import GHC.Core.FVs (exprFreeVars)+import GHC.Core.Map+import GHC.Core.SimpleOpt (simpleOptExpr, exprIsConApp_maybe)+import GHC.Core.Utils (exprType)+import GHC.Core.Make (mkListExpr, mkCharExpr)+import GHC.Types.Unique.Supply+import GHC.Data.FastString+import GHC.Types.SrcLoc+import GHC.Data.Maybe+import GHC.Core.ConLike+import GHC.Core.DataCon+import GHC.Core.PatSyn+import GHC.Core.TyCon+import GHC.Builtin.Types+import GHC.Builtin.Types.Prim (tYPETyCon)+import GHC.Core.TyCo.Rep+import GHC.Core.Type+import GHC.Tc.Solver (tcNormalise, tcCheckSatisfiability)+import GHC.Core.Unify (tcMatchTy)+import GHC.Core.Coercion+import GHC.HsToCore.Monad hiding (foldlM)+import GHC.Tc.Instance.Family+import GHC.Core.FamInstEnv++import Control.Applicative ((<|>))+import Control.Monad (foldM, forM, guard, mzero, when)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.State.Strict+import Data.Either (partitionEithers)+import Data.Foldable (foldlM, minimumBy, toList)+import Data.List (sortBy, find)+import qualified Data.List.NonEmpty as NE+import Data.Ord (comparing)++--+-- * Main exports+--++-- | Add a bunch of 'PhiCt's to all the 'Nabla's.+-- Lifts 'addPhiCts' over many 'Nablas'.+addPhiCtsNablas :: Nablas -> PhiCts -> DsM Nablas+addPhiCtsNablas nablas cts = liftNablasM (\d -> addPhiCts d cts) nablas++-- | 'addPmCtsNablas' for a single 'PmCt'.+addPhiCtNablas :: Nablas -> PhiCt -> DsM Nablas+addPhiCtNablas nablas ct = addPhiCtsNablas nablas (unitBag ct)++liftNablasM :: Monad m => (Nabla -> m (Maybe Nabla)) -> Nablas -> m Nablas+liftNablasM f (MkNablas ds) = MkNablas . catBagMaybes <$> (traverse f ds)++-- | Test if any of the 'Nabla's is inhabited. Currently this is pure, because+-- we preserve the invariant that there are no uninhabited 'Nabla's. But that+-- could change in the future, for example by implementing this function in+-- terms of @notNull <$> generateInhabitingPatterns 1 ds@.+isInhabited :: Nablas -> DsM Bool+isInhabited (MkNablas ds) = pure (not (null ds))++-----------------------------------------------+-- * Caching residual COMPLETE sets++-- See Note [Implementation of COMPLETE pragmas]++-- | Update the COMPLETE sets of 'ResidualCompleteMatches'.+updRcm :: (ConLikeSet -> ConLikeSet) -> ResidualCompleteMatches -> ResidualCompleteMatches+updRcm f (RCM vanilla pragmas) = RCM (f <$> vanilla) (fmap f <$> pragmas)++-- | A pseudo-'CompleteMatch' for the vanilla complete set of the given data+-- 'TyCon'.+-- Ex.: @vanillaCompleteMatchTC 'Maybe' ==> Just ("Maybe", {'Just','Nothing'})@+vanillaCompleteMatchTC :: TyCon -> Maybe ConLikeSet+vanillaCompleteMatchTC tc =+ let -- | TYPE acts like an empty data type on the term-level (#14086), but+ -- it is a PrimTyCon, so tyConDataCons_maybe returns Nothing. Hence a+ -- special case.+ mb_dcs | tc == tYPETyCon = Just []+ | otherwise = tyConDataCons_maybe tc+ in mkUniqDSet . map RealDataCon <$> mb_dcs++-- | Initialise from 'dsGetCompleteMatches' (containing all COMPLETE pragmas)+-- if the given 'ResidualCompleteMatches' were empty.+addCompleteMatches :: ResidualCompleteMatches -> DsM ResidualCompleteMatches+addCompleteMatches (RCM v Nothing) = RCM v . Just <$> dsGetCompleteMatches+addCompleteMatches rcm = pure rcm++-- | Adds the declared 'CompleteMatches' from COMPLETE pragmas, as well as the+-- vanilla data defn if it is a 'DataCon'.+addConLikeMatches :: ConLike -> ResidualCompleteMatches -> DsM ResidualCompleteMatches+addConLikeMatches (RealDataCon dc) rcm = addTyConMatches (dataConTyCon dc) rcm+addConLikeMatches (PatSynCon _) rcm = addCompleteMatches rcm++-- | Adds+-- * the 'CompleteMatches' from COMPLETE pragmas+-- * and the /vanilla/ 'CompleteMatch' from the data 'TyCon'+-- to the 'ResidualCompleteMatches', if not already present.+addTyConMatches :: TyCon -> ResidualCompleteMatches -> DsM ResidualCompleteMatches+addTyConMatches tc rcm = add_tc_match <$> addCompleteMatches rcm+ where+ -- | Add the vanilla COMPLETE set from the data defn, if any. But only if+ -- it's not already present.+ add_tc_match rcm+ = rcm{rcm_vanilla = rcm_vanilla rcm <|> vanillaCompleteMatchTC tc}++markMatched :: ConLike -> ResidualCompleteMatches -> DsM ResidualCompleteMatches+markMatched cl rcm = do+ rcm' <- addConLikeMatches cl rcm+ pure $ updRcm (flip delOneFromUniqDSet cl) rcm'++{-+Note [Implementation of COMPLETE pragmas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A COMPLETE set represents a set of conlikes (i.e., constructors or+pattern synonyms) such that if they are all pattern-matched against in a+function, it gives rise to a total function. An example is:++ newtype Boolean = Boolean Int+ pattern F, T :: Boolean+ pattern F = Boolean 0+ pattern T = Boolean 1+ {-# COMPLETE F, T #-}++ -- This is a total function+ booleanToInt :: Boolean -> Int+ booleanToInt F = 0+ booleanToInt T = 1++COMPLETE sets are represented internally in GHC a set of 'ConLike's. For+example, the pragma {-# COMPLETE F, T #-} would be represented as:++ {F, T}++GHC collects all COMPLETE pragmas from the current module and from imports+into a field in the DsM environment, which can be accessed with+dsGetCompleteMatches from "GHC.HsToCore.Monad".+Currently, COMPLETE pragmas can't be orphans (e.g. at least one ConLike must+also be defined in the module of the pragma) and do not impact recompilation+checking (#18675).++The pattern-match checker will then initialise each variable's 'VarInfo' with+*all* imported COMPLETE sets (in 'GHC.HsToCore.Pmc.Solver.addCompleteMatches'),+well-typed or not, into a 'ResidualCompleteMatches'. The trick is that a+COMPLETE set that is ill-typed for that match variable could never be written by+the user! And we make sure not to report any ill-typed COMPLETE sets when+formatting 'Nabla's for warnings in 'generateInhabitingPatterns'.++A 'ResidualCompleteMatches' is a list of all COMPLETE sets, minus the ConLikes+we know a particular variable can't be (through negative constructor constraints+@x /~ K@ or a failed attempt at instantiating that ConLike during inhabitation+testing). If *any* of the COMPLETE sets become empty, we know that the match+was exhaustive.++We assume that a COMPLETE set is non-empty if for one of its ConLikes+we fail to 'guessConLikeUnivTyArgsFromResTy'. That accounts for ill-typed+COMPLETE sets. So why don't we simply prune those ill-typed COMPLETE sets from+'ResidualCompleteMatches'? The answer is that additional type constraints might+make more COMPLETE sets applicable! Example:++ f :: a -> a :~: Boolean -> ()+ f x Refl | T <- x = ()+ | F <- x = ()++If we eagerly prune {F,T} from the residual matches of @x@, then we don't see+that the match in the guards of @f@ is exhaustive, where the COMPLETE set+applies due to refined type information.+-}++-----------------------+-- * Type normalisation++-- | The return value of 'pmTopNormaliseType'+data TopNormaliseTypeResult+ = NoChange Type+ -- ^ 'tcNormalise' failed to simplify the type and 'topNormaliseTypeX' was+ -- unable to reduce the outermost type application, so the type came out+ -- unchanged.+ | NormalisedByConstraints Type+ -- ^ 'tcNormalise' was able to simplify the type with some local constraint+ -- from the type oracle, but 'topNormaliseTypeX' couldn't identify a type+ -- redex.+ | HadRedexes Type [(Type, DataCon, Type)] Type+ -- ^ 'tcNormalise' may or may not been able to simplify the type, but+ -- 'topNormaliseTypeX' made progress either way and got rid of at least one+ -- outermost type or data family redex or newtype.+ -- The first field is the last type that was reduced solely through type+ -- family applications (possibly just the 'tcNormalise'd type). This is the+ -- one that is equal (in source Haskell) to the initial type.+ -- The third field is the type that we get when also looking through data+ -- family applications and newtypes. This would be the representation type in+ -- Core (modulo casts).+ -- The second field is the list of Newtype 'DataCon's that we looked through+ -- in the chain of reduction steps between the Source type and the Core type.+ -- We also keep the type of the DataCon application and its field, so that we+ -- don't have to reconstruct it in 'inhabitationCandidates' and+ -- 'generateInhabitingPatterns'.+ -- For an example, see Note [Type normalisation].++-- | Return the fields of 'HadRedexes'. Returns appropriate defaults in the+-- other cases.+tntrGuts :: TopNormaliseTypeResult -> (Type, [(Type, DataCon, Type)], Type)+tntrGuts (NoChange ty) = (ty, [], ty)+tntrGuts (NormalisedByConstraints ty) = (ty, [], ty)+tntrGuts (HadRedexes src_ty ds core_ty) = (src_ty, ds, core_ty)++instance Outputable TopNormaliseTypeResult where+ ppr (NoChange ty) = text "NoChange" <+> ppr ty+ ppr (NormalisedByConstraints ty) = text "NormalisedByConstraints" <+> ppr ty+ ppr (HadRedexes src_ty ds core_ty) = text "HadRedexes" <+> braces fields+ where+ fields = fsep (punctuate comma [ text "src_ty =" <+> ppr src_ty+ , text "newtype_dcs =" <+> ppr ds+ , text "core_ty =" <+> ppr core_ty ])++pmTopNormaliseType :: TyState -> Type -> DsM TopNormaliseTypeResult+-- ^ Get rid of *outermost* (or toplevel)+-- * type function redex+-- * data family redex+-- * newtypes+--+-- Behaves like `topNormaliseType_maybe`, but instead of returning a+-- coercion, it returns useful information for issuing pattern matching+-- warnings. See Note [Type normalisation] for details.+-- It also initially 'tcNormalise's the type with the bag of local constraints.+--+-- See 'TopNormaliseTypeResult' for the meaning of the return value.+--+-- NB: Normalisation can potentially change kinds, if the head of the type+-- is a type family with a variable result kind. I (Richard E) can't think+-- of a way to cause trouble here, though.+pmTopNormaliseType (TySt _ inert) typ+ = do env <- dsGetFamInstEnvs+ tracePm "normalise" (ppr typ)+ -- Before proceeding, we chuck typ into the constraint solver, in case+ -- solving for given equalities may reduce typ some. See+ -- "Wrinkle: local equalities" in Note [Type normalisation].+ (_, mb_typ') <- initTcDsForSolver $ tcNormalise inert typ+ -- If tcNormalise didn't manage to simplify the type, continue anyway.+ -- We might be able to reduce type applications nonetheless!+ let typ' = fromMaybe typ mb_typ'+ -- Now we look with topNormaliseTypeX through type and data family+ -- applications and newtypes, which tcNormalise does not do.+ -- See also 'TopNormaliseTypeResult'.+ pure $ case topNormaliseTypeX (stepper env) comb typ' of+ Nothing+ | Nothing <- mb_typ' -> NoChange typ+ | otherwise -> NormalisedByConstraints typ'+ Just ((ty_f,tm_f), ty) -> HadRedexes src_ty newtype_dcs core_ty+ where+ src_ty = eq_src_ty ty (typ' : ty_f [ty])+ newtype_dcs = tm_f []+ core_ty = ty+ where+ -- Find the first type in the sequence of rewrites that is a data type,+ -- newtype, or a data family application (not the representation tycon!).+ -- This is the one that is equal (in source Haskell) to the initial type.+ -- If none is found in the list, then all of them are type family+ -- applications, so we simply return the last one, which is the *simplest*.+ eq_src_ty :: Type -> [Type] -> Type+ eq_src_ty ty tys = maybe ty id (find is_closed_or_data_family tys)++ is_closed_or_data_family :: Type -> Bool+ is_closed_or_data_family ty = pmIsClosedType ty || isDataFamilyAppType ty++ -- For efficiency, represent both lists as difference lists.+ -- comb performs the concatenation, for both lists.+ comb (tyf1, tmf1) (tyf2, tmf2) = (tyf1 . tyf2, tmf1 . tmf2)++ stepper env = newTypeStepper `composeSteppers` tyFamStepper env++ -- A 'NormaliseStepper' that unwraps newtypes, careful not to fall into+ -- a loop. If it would fall into a loop, it produces 'NS_Abort'.+ newTypeStepper :: NormaliseStepper ([Type] -> [Type],[(Type, DataCon, Type)] -> [(Type, DataCon, Type)])+ newTypeStepper rec_nts tc tys+ | Just (ty', _co) <- instNewTyCon_maybe tc tys+ , let orig_ty = TyConApp tc tys+ = case checkRecTc rec_nts tc of+ Just rec_nts' -> let tyf = (orig_ty:)+ tmf = ((orig_ty, tyConSingleDataCon tc, ty'):)+ in NS_Step rec_nts' ty' (tyf, tmf)+ Nothing -> NS_Abort+ | otherwise+ = NS_Done++ tyFamStepper :: FamInstEnvs -> NormaliseStepper ([Type] -> [Type], a -> a)+ tyFamStepper env rec_nts tc tys -- Try to step a type/data family+ = case topReduceTyFamApp_maybe env tc tys of+ Just (_, rhs, _) -> NS_Step rec_nts rhs ((rhs:), id)+ _ -> NS_Done++-- | Returns 'True' if the argument 'Type' is a fully saturated application of+-- a closed type constructor.+--+-- Closed type constructors are those with a fixed right hand side, as+-- opposed to e.g. associated types. These are of particular interest for+-- pattern-match coverage checking, because GHC can exhaustively consider all+-- possible forms that values of a closed type can take on.+--+-- Note that this function is intended to be used to check types of value-level+-- patterns, so as a consequence, the 'Type' supplied as an argument to this+-- function should be of kind @Type@.+pmIsClosedType :: Type -> Bool+pmIsClosedType ty+ = case splitTyConApp_maybe ty of+ Just (tc, ty_args)+ | is_algebraic_like tc && not (isFamilyTyCon tc)+ -> ASSERT2( ty_args `lengthIs` tyConArity tc, ppr ty ) True+ _other -> False+ where+ -- This returns True for TyCons which /act like/ algebraic types.+ -- (See "Type#type_classification" for what an algebraic type is.)+ --+ -- This is qualified with \"like\" because of a particular special+ -- case: TYPE (the underlyind kind behind Type, among others). TYPE+ -- is conceptually a datatype (and thus algebraic), but in practice it is+ -- a primitive builtin type, so we must check for it specially.+ --+ -- NB: it makes sense to think of TYPE as a closed type in a value-level,+ -- pattern-matching context. However, at the kind level, TYPE is certainly+ -- not closed! Since this function is specifically tailored towards pattern+ -- matching, however, it's OK to label TYPE as closed.+ is_algebraic_like :: TyCon -> Bool+ is_algebraic_like tc = isAlgTyCon tc || tc == tYPETyCon++-- | Normalise the given source type to WHNF. If it isn't already in WHNF+-- ('isSourceTypeInWHNF') , it will normalise the type and then try to step+-- through type family applications, but not data family applications or+-- newtypes.+--+-- This is a pretty common case of calling 'pmTopNormaliseType' and it should be+-- efficient.+normaliseSourceTypeWHNF :: TyState -> Type -> DsM Type+normaliseSourceTypeWHNF _ ty | isSourceTypeInWHNF ty = pure ty+normaliseSourceTypeWHNF ty_st ty = do+ pmTopNormaliseType ty_st ty >>= \case+ NoChange ty -> pure ty+ NormalisedByConstraints ty -> pure ty+ HadRedexes ty _ _ -> pure ty++-- | Is the source type in WHNF wrt. 'pmTopNormaliseType'?+--+-- Returns False if the given type is not a TyCon application, or if the TyCon+-- app head is a type family TyCon. (But not for data family TyCons!)+isSourceTypeInWHNF :: Type -> Bool+isSourceTypeInWHNF ty+ | Just (tc, _) <- splitTyConApp_maybe ty = not (isTypeFamilyTyCon tc)+ | otherwise = False++{- Note [Type normalisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Constructs like -XEmptyCase or a previous unsuccessful pattern match on a data+constructor place a non-void constraint on the matched thing. This means that it+boils down to checking whether the type of the scrutinee is inhabited. Function+pmTopNormaliseType gets rid of the outermost type function/data family redex and+newtypes, in search of an algebraic type constructor, which is easier to check+for inhabitation.++It returns 3 results instead of one, because there are 2 subtle points:+1. Newtypes are isomorphic to the underlying type in core but not in the source+ language,+2. The representational data family tycon is used internally but should not be+ shown to the user++Hence, if pmTopNormaliseType env ty_cs ty = Just (src_ty, dcs, core_ty),+then+ (a) src_ty is the rewritten type which we can show to the user. That is, the+ type we get if we rewrite type families but not data families or+ newtypes.+ (b) dcs is the list of newtype constructors "skipped", every time we normalise+ a newtype to its core representation, we keep track of the source data+ constructor. For convenience, we also track the type we unwrap and the+ type of its field. Example: @Down 42@ => @[(Down @Int, Down, Int)]+ (c) core_ty is the rewritten type. That is,+ pmTopNormaliseType env ty_cs ty = Just (src_ty, dcs, core_ty)+ implies+ topNormaliseType_maybe env ty = Just (co, core_ty)+ for some coercion co.++To see how all cases come into play, consider the following example:++ data family T a :: *+ data instance T Int = T1 | T2 Bool+ -- Which gives rise to FC:+ -- data T a+ -- data R:TInt = T1 | T2 Bool+ -- axiom ax_ti : T Int ~R R:TInt++ newtype G1 = MkG1 (T Int)+ newtype G2 = MkG2 G1++ type instance F Int = F Char+ type instance F Char = G2++In this case pmTopNormaliseType env ty_cs (F Int) results in++ Just (G2, [(G2,MkG2,G1),(G1,MkG1,T Int)], R:TInt)++Which means that in source Haskell:+ - G2 is equivalent to F Int (in contrast, G1 isn't).+ - if (x : R:TInt) then (MkG2 (MkG1 x) : F Int).++-----+-- Wrinkle: Local equalities+-----++Given the following type family:++ type family F a+ type instance F Int = Void++Should the following program (from #14813) be considered exhaustive?++ f :: (i ~ Int) => F i -> a+ f x = case x of {}++You might think "of course, since `x` is obviously of type Void". But the+idType of `x` is technically F i, not Void, so if we pass F i to+inhabitationCandidates, we'll mistakenly conclude that `f` is non-exhaustive.+In order to avoid this pitfall, we need to normalise the type passed to+pmTopNormaliseType, using the constraint solver to solve for any local+equalities (such as i ~ Int) that may be in scope.+-}++-----------------------+-- * Looking up VarInfo++emptyRCM :: ResidualCompleteMatches+emptyRCM = RCM Nothing Nothing++emptyVarInfo :: Id -> VarInfo+emptyVarInfo x+ = VI+ { vi_id = x+ , vi_pos = []+ , vi_neg = emptyPmAltConSet+ -- Case (3) in Note [Strict fields and fields of unlifted type]+ , vi_bot = if isUnliftedType (idType x) then IsNotBot else MaybeBot+ , vi_rcm = emptyRCM+ }++lookupVarInfo :: TmState -> Id -> VarInfo+-- (lookupVarInfo tms x) tells what we know about 'x'+lookupVarInfo (TmSt env _ _) x = fromMaybe (emptyVarInfo x) (lookupUSDFM env x)++-- | Like @lookupVarInfo ts x@, but @lookupVarInfo ts x = (y, vi)@ also looks+-- through newtype constructors. We have @x ~ N1 (... (Nk y))@ such that the+-- returned @y@ doesn't have a positive newtype constructor constraint+-- associated with it (yet). The 'VarInfo' returned is that of @y@'s+-- representative.+--+-- Careful, this means that @idType x@ might be different to @idType y@, even+-- modulo type normalisation!+--+-- See also Note [Coverage checking Newtype matches].+lookupVarInfoNT :: TmState -> Id -> (Id, VarInfo)+lookupVarInfoNT ts x = case lookupVarInfo ts x of+ VI{ vi_pos = as_newtype -> Just y } -> lookupVarInfoNT ts y+ res -> (x, res)+ where+ as_newtype = listToMaybe . mapMaybe go+ go PACA{paca_con = PmAltConLike (RealDataCon dc), paca_ids = [y]}+ | isNewDataCon dc = Just y+ go _ = Nothing++trvVarInfo :: Functor f => (VarInfo -> f (a, VarInfo)) -> Nabla -> Id -> f (a, Nabla)+trvVarInfo f nabla@MkNabla{ nabla_tm_st = ts@TmSt{ts_facts = env} } x+ = set_vi <$> f (lookupVarInfo ts x)+ where+ set_vi (a, vi') =+ (a, nabla{ nabla_tm_st = ts{ ts_facts = addToUSDFM env (vi_id vi') vi' } })++{- Note [Coverage checking Newtype matches]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Newtypes have quite peculiar match semantics compared to ordinary DataCons. In a+pattern-match, they behave like a irrefutable (lazy) match, but for inhabitation+testing purposes (e.g. at construction sites), they behave rather like a DataCon+with a *strict* field, because they don't contribute their own bottom and are+inhabited iff the wrapped type is inhabited.++This distinction becomes apparent in #17248:++ newtype T2 a = T2 a+ g _ True = ()+ g (T2 _) True = ()+ g !_ True = ()++If we treat Newtypes like we treat regular DataCons, we would mark the third+clause as redundant, which clearly is unsound. The solution:+1. 'isPmAltConMatchStrict' returns False for newtypes, indicating that a+ newtype match is lazy.+2. When we find @x ~ T2 y@, transfer all constraints on @x@ (which involve @⊥@)+ to @y@, similar to what 'equate' does, and don't add a @x ≁ ⊥@ constraint.+ This way, the third clause will still be marked as inaccessible RHS instead+ of redundant. This is ensured by calling 'lookupVarInfoNT'.+3. Immediately reject when we find @x ≁ T2@.+Handling of Newtypes is also described in the Appendix of the Lower Your Guards paper,+where you can find the solution in a perhaps more digestible format.+-}++------------------------------------------------+-- * Exported utility functions querying 'Nabla'++lookupRefuts :: Nabla -> Id -> [PmAltCon]+-- Unfortunately we need the extra bit of polymorphism and the unfortunate+-- duplication of lookupVarInfo here.+lookupRefuts MkNabla{ nabla_tm_st = ts } x =+ pmAltConSetElems $ vi_neg $ lookupVarInfo ts x++isDataConSolution :: PmAltConApp -> Bool+isDataConSolution PACA{paca_con = PmAltConLike (RealDataCon _)} = True+isDataConSolution _ = False++-- @lookupSolution nabla x@ picks a single solution ('vi_pos') of @x@ from+-- possibly many, preferring 'RealDataCon' solutions whenever possible.+lookupSolution :: Nabla -> Id -> Maybe PmAltConApp+lookupSolution nabla x = case vi_pos (lookupVarInfo (nabla_tm_st nabla) x) of+ [] -> Nothing+ pos+ | Just sol <- find isDataConSolution pos -> Just sol+ | otherwise -> Just (head pos)++-------------------------+-- * Adding φ constraints+--+-- Figure 7 in the LYG paper.++-- | A high-level pattern-match constraint. Corresponds to φ from Figure 3 of+-- the LYG paper.+data PhiCt+ = PhiTyCt !PredType+ -- ^ A type constraint "T ~ U".+ | PhiCoreCt !Id !CoreExpr+ -- ^ @PhiCoreCt x e@ encodes "x ~ e", equating @x@ with the 'CoreExpr' @e@.+ | PhiConCt !Id !PmAltCon ![TyVar] ![PredType] ![Id]+ -- ^ @PhiConCt x K tvs dicts ys@ encodes @K \@tvs dicts ys <- x@, matching @x@+ -- against the 'PmAltCon' application @K \@tvs dicts ys@, binding @tvs@,+ -- @dicts@ and possibly unlifted fields @ys@ in the process.+ -- See Note [Strict fields and fields of unlifted type].+ | PhiNotConCt !Id !PmAltCon+ -- ^ @PhiNotConCt x K@ encodes "x ≁ K", asserting that @x@ can't be headed+ -- by @K@.+ | PhiBotCt !Id+ -- ^ @PhiBotCt x@ encodes "x ~ ⊥", equating @x@ to ⊥.+ -- by @K@.+ | PhiNotBotCt !Id+ -- ^ @PhiNotBotCt x y@ encodes "x ≁ ⊥", asserting that @x@ can't be ⊥.++instance Outputable PhiCt where+ ppr (PhiTyCt ty_ct) = ppr ty_ct+ ppr (PhiCoreCt x e) = ppr x <+> char '~' <+> ppr e+ ppr (PhiConCt x con tvs dicts args) =+ hsep (ppr con : pp_tvs ++ pp_dicts ++ pp_args) <+> text "<-" <+> ppr x+ where+ pp_tvs = map ((<> char '@') . ppr) tvs+ pp_dicts = map ppr dicts+ pp_args = map ppr args+ ppr (PhiNotConCt x con) = ppr x <+> text "≁" <+> ppr con+ ppr (PhiBotCt x) = ppr x <+> text "~ ⊥"+ ppr (PhiNotBotCt x) = ppr x <+> text "≁ ⊥"++type PhiCts = Bag PhiCt++-- | The fuel for the inhabitation test.+-- See Note [Fuel for the inhabitation test].+initFuel :: Int+initFuel = 4 -- 4 because it's the smallest number that passes f' in T17977b++-- | Adds new constraints to 'Nabla' and returns 'Nothing' if that leads to a+-- contradiction.+--+-- In terms of the paper, this function models the \(⊕_φ\) function in+-- Figure 7 on batches of φ constraints.+addPhiCts :: Nabla -> PhiCts -> DsM (Maybe Nabla)+-- See Note [TmState invariants].+addPhiCts nabla cts = runMaybeT $ do+ let (ty_cts, tm_cts) = partitionPhiCts cts+ nabla' <- addTyCts nabla (listToBag ty_cts)+ nabla'' <- foldlM addPhiTmCt nabla' (listToBag tm_cts)+ inhabitationTest initFuel (nabla_ty_st nabla) nabla''++partitionPhiCts :: PhiCts -> ([PredType], [PhiCt])+partitionPhiCts = partitionEithers . map to_either . toList+ where+ to_either (PhiTyCt pred_ty) = Left pred_ty+ to_either ct = Right ct++-----------------------------+-- ** Adding type constraints++-- | Adds new type-level constraints by calling out to the type-checker via+-- 'tyOracle'.+addTyCts :: Nabla -> Bag PredType -> MaybeT DsM Nabla+addTyCts nabla@MkNabla{ nabla_ty_st = ty_st } new_ty_cs = do+ ty_st' <- MaybeT (tyOracle ty_st new_ty_cs)+ pure nabla{ nabla_ty_st = ty_st' }++-- | Add some extra type constraints to the 'TyState'; return 'Nothing' if we+-- find a contradiction (e.g. @Int ~ Bool@).+tyOracle :: TyState -> Bag PredType -> DsM (Maybe TyState)+tyOracle ty_st@(TySt n inert) cts+ | isEmptyBag cts+ = pure (Just ty_st)+ | otherwise+ = do { evs <- traverse nameTyCt cts+ ; tracePm "tyOracle" (ppr cts $$ ppr inert)+ ; ((_warns, errs), res) <- initTcDsForSolver $ tcCheckSatisfiability inert evs+ ; case res of+ -- return the new inert set and increment the sequence number n+ Just mb_new_inert -> return (TySt (n+1) <$> mb_new_inert)+ Nothing -> pprPanic "tyOracle" (vcat $ pprErrMsgBagWithLoc errs) }++-- | Allocates a fresh 'EvVar' name for 'PredTy's.+nameTyCt :: PredType -> DsM EvVar+nameTyCt pred_ty = do+ unique <- getUniqueM+ let occname = mkVarOccFS (fsLit ("pm_"++show unique))+ idname = mkInternalName unique occname noSrcSpan+ return (mkLocalIdOrCoVar idname Many pred_ty)++-----------------------------+-- ** Adding term constraints++-- | Adds a single higher-level φ constraint by dispatching to the various+-- oracle functions.+--+-- In terms of the paper, this function amounts to the constructor constraint+-- case of \(⊕_φ\) in Figure 7, which "desugars" higher-level φ constraints+-- into lower-level δ constraints. We don't have a data type for δ constraints+-- and call the corresponding oracle function directly instead.+--+-- Precondition: The φ is /not/ a type constraint! These should be handled by+-- 'addTyCts' before, through 'addPhiCts'.+addPhiTmCt :: Nabla -> PhiCt -> MaybeT DsM Nabla+addPhiTmCt _ (PhiTyCt ct) = pprPanic "addPhiCt:TyCt" (ppr ct) -- See the precondition+addPhiTmCt nabla (PhiCoreCt x e) = addCoreCt nabla x e+addPhiTmCt nabla (PhiConCt x con tvs dicts args) = do+ -- Case (1) of Note [Strict fields and variables of unlifted type]+ -- PhiConCt correspond to the higher-level φ constraints from the paper with+ -- bindings semantics. It disperses into lower-level δ constraints that the+ -- 'add*Ct' functions correspond to.+ nabla' <- addTyCts nabla (listToBag dicts)+ nabla'' <- addConCt nabla' x con tvs args+ foldlM addNotBotCt nabla'' (filterUnliftedFields con args)+addPhiTmCt nabla (PhiNotConCt x con) = addNotConCt nabla x con+addPhiTmCt nabla (PhiBotCt x) = addBotCt nabla x+addPhiTmCt nabla (PhiNotBotCt x) = addNotBotCt nabla x++filterUnliftedFields :: PmAltCon -> [Id] -> [Id]+filterUnliftedFields con args =+ [ arg | (arg, bang) <- zipEqual "addPhiCt" args (pmAltConImplBangs con)+ , isBanged bang || isUnliftedType (idType arg) ]++-- | Adds the constraint @x ~ ⊥@, e.g. that evaluation of a particular 'Id' @x@+-- surely diverges. Quite similar to 'addConCt', only that it only cares about+-- ⊥.+addBotCt :: Nabla -> Id -> MaybeT DsM Nabla+addBotCt nabla@MkNabla{ nabla_tm_st = ts@TmSt{ ts_facts=env } } x = do+ let (y, vi@VI { vi_bot = bot }) = lookupVarInfoNT (nabla_tm_st nabla) x+ case bot of+ IsNotBot -> mzero -- There was x ≁ ⊥. Contradiction!+ IsBot -> pure nabla -- There already is x ~ ⊥. Nothing left to do+ MaybeBot -> do -- We add x ~ ⊥+ let vi' = vi{ vi_bot = IsBot }+ pure nabla{ nabla_tm_st = ts{ts_facts = addToUSDFM env y vi' } }++-- | Adds the constraint @x ~/ ⊥@ to 'Nabla'. Quite similar to 'addNotConCt',+-- but only cares for the ⊥ "constructor".+addNotBotCt :: Nabla -> Id -> MaybeT DsM Nabla+addNotBotCt nabla@MkNabla{ nabla_tm_st = ts@TmSt{ts_facts=env} } x = do+ let (y, vi@VI { vi_bot = bot }) = lookupVarInfoNT (nabla_tm_st nabla) x+ case bot of+ IsBot -> mzero -- There was x ~ ⊥. Contradiction!+ IsNotBot -> pure nabla -- There already is x ≁ ⊥. Nothing left to do+ MaybeBot -> do -- We add x ≁ ⊥ and test if x is still inhabited+ -- Mark dirty for a delayed inhabitation test+ let vi' = vi{ vi_bot = IsNotBot}+ pure $ markDirty y+ $ nabla{ nabla_tm_st = ts{ ts_facts = addToUSDFM env y vi' } }++-- | Record a @x ~/ K@ constraint, e.g. that a particular 'Id' @x@ can't+-- take the shape of a 'PmAltCon' @K@ in the 'Nabla' and return @Nothing@ if+-- that leads to a contradiction.+-- See Note [TmState invariants].+addNotConCt :: Nabla -> Id -> PmAltCon -> MaybeT DsM Nabla+addNotConCt _ _ (PmAltConLike (RealDataCon dc))+ | isNewDataCon dc = mzero -- (3) in Note [Coverage checking Newtype matches]+addNotConCt nabla x nalt = do+ (mb_mark_dirty, nabla') <- trvVarInfo go nabla x+ pure $ case mb_mark_dirty of+ Just x -> markDirty x nabla'+ Nothing -> nabla'+ where+ go vi@(VI x' pos neg _ rcm) = do+ -- 1. Bail out quickly when nalt contradicts a solution+ let contradicts nalt sol = eqPmAltCon (paca_con sol) nalt == Equal+ guard (not (any (contradicts nalt) pos))+ -- 2. Only record the new fact when it's not already implied by one of the+ -- solutions+ let implies nalt sol = eqPmAltCon (paca_con sol) nalt == Disjoint+ let neg'+ | any (implies nalt) pos = neg+ -- See Note [Completeness checking with required Thetas]+ | hasRequiredTheta nalt = neg+ | otherwise = extendPmAltConSet neg nalt+ MASSERT( isPmAltConMatchStrict nalt )+ let vi' = vi{ vi_neg = neg', vi_bot = IsNotBot }+ -- 3. Make sure there's at least one other possible constructor+ case nalt of+ PmAltConLike cl -> do+ -- Mark dirty to force a delayed inhabitation test+ rcm' <- lift (markMatched cl rcm)+ pure (Just x', vi'{ vi_rcm = rcm' })+ _ ->+ pure (Nothing, vi')++hasRequiredTheta :: PmAltCon -> Bool+hasRequiredTheta (PmAltConLike cl) = notNull req_theta+ where+ (_,_,_,_,req_theta,_,_) = conLikeFullSig cl+hasRequiredTheta _ = False++-- | Add a @x ~ K tvs args ts@ constraint.+-- @addConCt x K tvs args ts@ extends the substitution with a solution+-- @x :-> (K, tvs, args)@ if compatible with the negative and positive info we+-- have on @x@, reject (@Nothing@) otherwise.+--+-- See Note [TmState invariants].+addConCt :: Nabla -> Id -> PmAltCon -> [TyVar] -> [Id] -> MaybeT DsM Nabla+addConCt nabla@MkNabla{ nabla_tm_st = ts@TmSt{ ts_facts=env } } x alt tvs args = do+ let vi@(VI _ pos neg bot _) = lookupVarInfo ts x+ -- First try to refute with a negative fact+ guard (not (elemPmAltConSet alt neg))+ -- Then see if any of the other solutions (remember: each of them is an+ -- additional refinement of the possible values x could take) indicate a+ -- contradiction+ guard (all ((/= Disjoint) . eqPmAltCon alt . paca_con) pos)+ -- Now we should be good! Add (alt, tvs, args) as a possible solution, or+ -- refine an existing one+ case find ((== Equal) . eqPmAltCon alt . paca_con) pos of+ Just (PACA _con other_tvs other_args) -> do+ -- We must unify existentially bound ty vars and arguments!+ let ty_cts = equateTys (map mkTyVarTy tvs) (map mkTyVarTy other_tvs)+ when (length args /= length other_args) $+ lift $ tracePm "error" (ppr x <+> ppr alt <+> ppr args <+> ppr other_args)+ nabla' <- MaybeT $ addPhiCts nabla (listToBag ty_cts)+ let add_var_ct nabla (a, b) = addVarCt nabla a b+ foldlM add_var_ct nabla' $ zipEqual "addConCt" args other_args+ Nothing -> do+ let pos' = PACA alt tvs args : pos+ let nabla_with bot' =+ nabla{ nabla_tm_st = ts{ts_facts = addToUSDFM env x (vi{vi_pos = pos', vi_bot = bot'})} }+ -- Do (2) in Note [Coverage checking Newtype matches]+ case (alt, args) of+ (PmAltConLike (RealDataCon dc), [y]) | isNewDataCon dc ->+ case bot of+ MaybeBot -> pure (nabla_with MaybeBot)+ IsBot -> addBotCt (nabla_with MaybeBot) y+ IsNotBot -> addNotBotCt (nabla_with MaybeBot) y+ _ -> ASSERT( isPmAltConMatchStrict alt )+ pure (nabla_with IsNotBot) -- strict match ==> not ⊥++equateTys :: [Type] -> [Type] -> [PhiCt]+equateTys ts us =+ [ PhiTyCt (mkPrimEqPred t u)+ | (t, u) <- zipEqual "equateTys" ts us+ -- The following line filters out trivial Refl constraints, so that we don't+ -- need to initialise the type oracle that often+ , not (eqType t u)+ ]++-- | Adds a @x ~ y@ constraint by merging the two 'VarInfo's and record the+-- gained knowledge in 'Nabla'.+--+-- Returns @Nothing@ when there's a contradiction while merging. Returns @Just+-- nabla@ when the constraint was compatible with prior facts, in which case+-- @nabla@ has integrated the knowledge from the equality constraint.+--+-- See Note [TmState invariants].+addVarCt :: Nabla -> Id -> Id -> MaybeT DsM Nabla+addVarCt nabla@MkNabla{ nabla_tm_st = ts@TmSt{ ts_facts = env } } x y =+ case equateUSDFM env x y of+ (Nothing, env') -> pure (nabla{ nabla_tm_st = ts{ ts_facts = env' } })+ -- Add the constraints we had for x to y+ (Just vi_x, env') -> do+ let nabla_equated = nabla{ nabla_tm_st = ts{ts_facts = env'} }+ -- and then gradually merge every positive fact we have on x into y+ let add_pos nabla (PACA cl tvs args) = addConCt nabla y cl tvs args+ nabla_pos <- foldlM add_pos nabla_equated (vi_pos vi_x)+ -- Do the same for negative info+ let add_neg nabla nalt = addNotConCt nabla y nalt+ foldlM add_neg nabla_pos (pmAltConSetElems (vi_neg vi_x))++-- | Inspects a 'PmCoreCt' @let x = e@ by recording constraints for @x@ based+-- on the shape of the 'CoreExpr' @e@. Examples:+--+-- * For @let x = Just (42, 'z')@ we want to record the+-- constraints @x ~ Just a, a ~ (b, c), b ~ 42, c ~ 'z'@.+-- See 'data_con_app'.+-- * For @let x = unpackCString# "tmp"@ we want to record the literal+-- constraint @x ~ "tmp"@.+-- * For @let x = I# 42@ we want the literal constraint @x ~ 42@. Similar+-- for other literals. See 'coreExprAsPmLit'.+-- * Finally, if we have @let x = e@ and we already have seen @let y = e@, we+-- want to record @x ~ y@.+addCoreCt :: Nabla -> Id -> CoreExpr -> MaybeT DsM Nabla+addCoreCt nabla x e = do+ simpl_opts <- initSimpleOpts <$> getDynFlags+ let e' = simpleOptExpr simpl_opts e+ -- lift $ tracePm "addCoreCt" (ppr x <+> dcolon <+> ppr (idType x) $$ ppr e $$ ppr e')+ execStateT (core_expr x e') nabla+ where+ -- | Takes apart a 'CoreExpr' and tries to extract as much information about+ -- literals and constructor applications as possible.+ core_expr :: Id -> CoreExpr -> StateT Nabla (MaybeT DsM) ()+ -- TODO: Handle newtypes properly, by wrapping the expression in a DataCon+ -- This is the right thing for casts involving data family instances and+ -- their representation TyCon, though (which are not visible in source+ -- syntax). See Note [COMPLETE sets on data families]+ -- core_expr x e | pprTrace "core_expr" (ppr x $$ ppr e) False = undefined+ core_expr x (Cast e _co) = core_expr x e+ core_expr x (Tick _t e) = core_expr x e+ core_expr x e+ | Just (pmLitAsStringLit -> Just s) <- coreExprAsPmLit e+ , expr_ty `eqType` stringTy+ -- See Note [Representation of Strings in TmState]+ = case unpackFS s of+ -- We need this special case to break a loop with coreExprAsPmLit+ -- Otherwise we alternate endlessly between [] and ""+ [] -> data_con_app x emptyInScopeSet nilDataCon []+ s' -> core_expr x (mkListExpr charTy (map mkCharExpr s'))+ | Just lit <- coreExprAsPmLit e+ = pm_lit x lit+ | Just (in_scope, _empty_floats@[], dc, _arg_tys, args)+ <- exprIsConApp_maybe in_scope_env e+ = data_con_app x in_scope dc args+ -- See Note [Detecting pattern synonym applications in expressions]+ | Var y <- e, Nothing <- isDataConId_maybe x+ -- We don't consider DataCons flexible variables+ = modifyT (\nabla -> addVarCt nabla x y)+ | otherwise+ -- Any other expression. Try to find other uses of a semantically+ -- equivalent expression and represent them by the same variable!+ = equate_with_similar_expr x e+ where+ expr_ty = exprType e+ expr_in_scope = mkInScopeSet (exprFreeVars e)+ in_scope_env = (expr_in_scope, const NoUnfolding)+ -- It's inconvenient to get hold of a global in-scope set+ -- here, but it'll only be needed if exprIsConApp_maybe ends+ -- up substituting inside a forall or lambda (i.e. seldom)+ -- so using exprFreeVars seems fine. See MR !1647.++ -- | The @e@ in @let x = e@ had no familiar form. But we can still see if+ -- see if we already encountered a constraint @let y = e'@ with @e'@+ -- semantically equivalent to @e@, in which case we may add the constraint+ -- @x ~ y@.+ equate_with_similar_expr :: Id -> CoreExpr -> StateT Nabla (MaybeT DsM) ()+ equate_with_similar_expr x e = do+ rep <- StateT $ \nabla -> lift (representCoreExpr nabla e)+ -- Note that @rep == x@ if we encountered @e@ for the first time.+ modifyT (\nabla -> addVarCt nabla x rep)++ bind_expr :: CoreExpr -> StateT Nabla (MaybeT DsM) Id+ bind_expr e = do+ x <- lift (lift (mkPmId (exprType e)))+ core_expr x e+ pure x++ -- | Look at @let x = K taus theta es@ and generate the following+ -- constraints (assuming universals were dropped from @taus@ before):+ -- 1. @x ≁ ⊥@ if 'K' is not a Newtype constructor.+ -- 2. @a_1 ~ tau_1, ..., a_n ~ tau_n@ for fresh @a_i@+ -- 3. @y_1 ~ e_1, ..., y_m ~ e_m@ for fresh @y_i@+ -- 4. @x ~ K as ys@+ -- This is quite similar to PmCheck.pmConCts.+ data_con_app :: Id -> InScopeSet -> DataCon -> [CoreExpr] -> StateT Nabla (MaybeT DsM) ()+ data_con_app x in_scope dc args = do+ let dc_ex_tvs = dataConExTyCoVars dc+ arty = dataConSourceArity dc+ (ex_ty_args, val_args) = splitAtList dc_ex_tvs args+ ex_tys = map exprToType ex_ty_args+ vis_args = reverse $ take arty $ reverse val_args+ uniq_supply <- lift $ lift $ getUniqueSupplyM+ let (_, ex_tvs) = cloneTyVarBndrs (mkEmptyTCvSubst in_scope) dc_ex_tvs uniq_supply+ ty_cts = equateTys (map mkTyVarTy ex_tvs) ex_tys+ -- 1. @x ≁ ⊥@ if 'K' is not a Newtype constructor (#18341)+ when (not (isNewDataCon dc)) $+ modifyT $ \nabla -> addNotBotCt nabla x+ -- 2. @a_1 ~ tau_1, ..., a_n ~ tau_n@ for fresh @a_i@. See also #17703+ modifyT $ \nabla -> MaybeT $ addPhiCts nabla (listToBag ty_cts)+ -- 3. @y_1 ~ e_1, ..., y_m ~ e_m@ for fresh @y_i@+ arg_ids <- traverse bind_expr vis_args+ -- 4. @x ~ K as ys@+ pm_alt_con_app x (PmAltConLike (RealDataCon dc)) ex_tvs arg_ids++ -- | Adds a literal constraint, i.e. @x ~ 42@.+ -- Also we assume that literal expressions won't diverge, so this+ -- will add a @x ~/ ⊥@ constraint.+ pm_lit :: Id -> PmLit -> StateT Nabla (MaybeT DsM) ()+ pm_lit x lit = do+ modifyT $ \nabla -> addNotBotCt nabla x+ pm_alt_con_app x (PmAltLit lit) [] []++ -- | Adds the given constructor application as a solution for @x@.+ pm_alt_con_app :: Id -> PmAltCon -> [TyVar] -> [Id] -> StateT Nabla (MaybeT DsM) ()+ pm_alt_con_app x con tvs args = modifyT $ \nabla -> addConCt nabla x con tvs args++-- | Finds a representant of the semantic equality class of the given @e@.+-- Which is the @x@ of a @let x = e'@ constraint (with @e@ semantically+-- equivalent to @e'@) we encountered earlier, or a fresh identifier if+-- there weren't any such constraints.+representCoreExpr :: Nabla -> CoreExpr -> DsM (Id, Nabla)+representCoreExpr nabla@MkNabla{ nabla_tm_st = ts@TmSt{ ts_reps = reps } } e+ | Just rep <- lookupCoreMap reps e = pure (rep, nabla)+ | otherwise = do+ rep <- mkPmId (exprType e)+ let reps' = extendCoreMap reps e rep+ let nabla' = nabla{ nabla_tm_st = ts{ ts_reps = reps' } }+ pure (rep, nabla')++-- | Like 'modify', but with an effectful modifier action+modifyT :: Monad m => (s -> m s) -> StateT s m ()+modifyT f = StateT $ fmap ((,) ()) . f++{- Note [The Pos/Neg invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Invariant applying to each VarInfo: Whenever we have @C @tvs args@ in 'vi_pos',+any entry in 'vi_neg' must be incomparable to C (return Nothing) according to+'eqPmAltCons'. Those entries that are comparable either lead to a refutation+or are redundant. Examples:+* @x ~ Just y@, @x ≁ [Just]@. 'eqPmAltCon' returns @Equal@, so refute.+* @x ~ Nothing@, @x ≁ [Just]@. 'eqPmAltCon' returns @Disjoint@, so negative+ info is redundant and should be discarded.+* @x ~ I# y@, @x ≁ [4,2]@. 'eqPmAltCon' returns @PossiblyOverlap@, so orthogal.+ We keep this info in order to be able to refute a redundant match on i.e. 4+ later on.++This carries over to pattern synonyms and overloaded literals. Say, we have+ pattern Just42 = Just 42+ case Just42 of x+ Nothing -> ()+ Just _ -> ()+Even though we had a solution for the value abstraction called x here in form+of a PatSynCon Just42, this solution is incomparable to both Nothing and+Just. Hence we retain the info in vi_neg, which eventually allows us to detect+the complete pattern match.++The Pos/Neg invariant extends to vi_rcm, which essentially stores positive+information. We make sure that vi_neg and vi_rcm never overlap. This isn't+strictly necessary since vi_rcm is just a cache, so doesn't need to be+accurate: Every suggestion of a possible ConLike from vi_rcm might be+refutable by the type oracle anyway. But it helps to maintain sanity while+debugging traces.++Note [Why record both positive and negative info?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+You might think that knowing positive info (like x ~ Just y) would render+negative info irrelevant, but not so because of pattern synonyms. E.g we might+know that x cannot match (Foo 4), where pattern Foo p = Just p++Also overloaded literals themselves behave like pattern synonyms. E.g if+postively we know that (x ~ I# y), we might also negatively want to record that+x does not match 45 f 45 = e2 f (I# 22#) = e3 f 45 = e4 --+Overlapped++Note [TmState invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~+The term oracle state is never obviously (i.e., without consulting the type+oracle or doing inhabitation testing) contradictory. This implies a few+invariants:+* Whenever vi_pos overlaps with vi_neg according to 'eqPmAltCon', we refute.+ This is implied by the Note [Pos/Neg invariant].+* Whenever vi_neg subsumes a COMPLETE set, we refute. We consult vi_rcm to+ detect this, but we could just compare whole COMPLETE sets to vi_neg every+ time, if it weren't for performance.++Maintaining these invariants in 'addVarCt' (the core of the term oracle) and+'addNotConCt' is subtle.+* Merging VarInfos. Example: Add the fact @x ~ y@ (see 'equate').+ - (COMPLETE) If we had @x ≁ True@ and @y ≁ False@, then we get+ @x ≁ [True,False]@. This is vacuous by matter of comparing to the built-in+ COMPLETE set, so should refute.+ - (Pos/Neg) If we had @x ≁ True@ and @y ~ True@, we have to refute.+* Adding positive information. Example: Add the fact @x ~ K ys@ (see 'addConCt')+ - (Neg) If we had @x ≁ K@, refute.+ - (Pos) If we had @x ~ K2@, and that contradicts the new solution according to+ 'eqPmAltCon' (ex. K2 is [] and K is (:)), then refute.+ - (Refine) If we had @x ≁ K zs@, unify each y with each z in turn.+* Adding negative information. Example: Add the fact @x ≁ Nothing@ (see 'addNotConCt')+ - (Refut) If we have @x ~ K ys@, refute.+ - (COMPLETE) If K=Nothing and we had @x ≁ Just@, then we get+ @x ≁ [Just,Nothing]@. This is vacuous by matter of comparing to the built-in+ COMPLETE set, so should refute.++Note that merging VarInfo in equate can be done by calling out to 'addConCt' and+'addNotConCt' for each of the facts individually.++Note [Representation of Strings in TmState]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Instead of treating regular String literals as a PmLits, we treat it as a list+of characters in the oracle for better overlap reasoning. The following example+shows why:++ f :: String -> ()+ f ('f':_) = ()+ f "foo" = ()+ f _ = ()++The second case is redundant, and we like to warn about it. Therefore either+the oracle will have to do some smart conversion between the list and literal+representation or treat is as the list it really is at runtime.++The "smart conversion" has the advantage of leveraging the more compact literal+representation wherever possible, but is really nasty to get right with negative+equalities: Just think of how to encode @x /= "foo"@.+The "list" option is far simpler, but incurs some overhead in representation and+warning messages (which can be alleviated by someone with enough dedication).++Note [Detecting pattern synonym applications in expressions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+At the moment we fail to detect pattern synonyms in scrutinees and RHS of+guards. This could be alleviated with considerable effort and complexity, but+the returns are meager. Consider:++ pattern P+ pattern Q+ case P 15 of+ Q _ -> ...+ P 15 ->++Compared to the situation where P and Q are DataCons, the lack of generativity+means we could never flag Q as redundant. (also see Note [Undecidable Equality+for PmAltCons] in PmTypes.) On the other hand, if we fail to recognise the+pattern synonym, we flag the pattern match as inexhaustive. That wouldn't happen+if we had knowledge about the scrutinee, in which case the oracle basically+knows "If it's a P, then its field is 15".++This is a pretty narrow use case and I don't think we should to try to fix it+until a user complains energetically.++Note [Completeness checking with required Thetas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the situation in #11224++ import Text.Read (readMaybe)+ pattern PRead :: Read a => () => a -> String+ pattern PRead x <- (readMaybe -> Just x)+ f :: String -> Int+ f (PRead x) = x+ f (PRead xs) = length xs+ f _ = 0++Is the first match exhaustive on the PRead synonym? Should the second line thus+deemed redundant? The answer is, of course, No! The required theta is like a+hidden parameter which must be supplied at the pattern match site, so PRead+is much more like a view pattern (where behavior depends on the particular value+passed in).+The simple solution here is to forget in 'addNotConCt' that we matched+on synonyms with a required Theta like @PRead@, so that subsequent matches on+the same constructor are never flagged as redundant. The consequence is that+we no longer detect the actually redundant match in++ g :: String -> Int+ g (PRead x) = x+ g (PRead y) = y -- redundant!+ g _ = 0++But that's a small price to pay, compared to the proper solution here involving+storing required arguments along with the PmAltConLike in 'vi_neg'.++Note [Strict fields and variables of unlifted type]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Binders of unlifted type (and strict fields) are unlifted by construction;+they are conceived with an implicit @≁⊥@ constraint to begin with. Hence,+desugaring in "GHC.HsToCore.Pmc" is entirely unconcerned by strict fields,+since the forcing happens *before* pattern matching.+And the φ constructor constraints emitted by 'GHC.HsToCore.Pmc.checkGrd'+have complex binding semantics (binding type constraints and unlifted fields),+so unliftedness semantics are entirely confined to the oracle.++These are the moving parts:++ 1. For each strict (or more generally, unlifted) field @s@ of a 'PhiConCt'+ we have to add a @s ≁ ⊥@ constraint in the corresponding case of+ 'addPhiTmCt'. Strict fields are devoid of ⊥ by construction, there's+ nothing that a bang pattern would act on. Example from #18341:++ data T = MkT !Int+ f :: T -> ()+ f (MkT _) | False = () -- inaccessible+ f (MkT !_) | False = () -- redundant, not only inaccessible!+ f _ = ()++ The second clause desugars to @MkT n <- x, !n@. When coverage checked,+ the 'PmCon' @MkT n <- x@ refines the set of values that reach the bang+ pattern with the φ constraints @MkT n <- x@ (Nothing surprising so far).+ Upon that constraint, it disperses into two lower-level δ constraints+ @x ~ MkT n, n ≁ ⊥@ per Equation (3) in Figure 7 of the paper.++ Checking the 'PmBang' @!n@ will then try to add the+ constraint @n ~ ⊥@ to this set to get the diverging set, which is found+ to be empty. Hence the whole clause is detected as redundant, as+ expected.++ 2. Similarly, when performing the 'inhabitationTest', when instantiating a+ constructor we call 'instCon', which generates a higher-level φ+ constructor constraint.++ 3. The preceding points handle unlifted constructor fields, but there also+ are regular binders of unlifted type.+ Since the oracle as implemented has no notion of scoping and bindings,+ we can't know *when* an unlifted variable comes into scope. But that's+ not actually a problem, because we can just add the @x ≁ ⊥@ to the+ 'emptyVarInfo' when we first encounter it.+-}++-------------------------+-- * Inhabitation testing+--+-- Figure 8 in the LYG paper.++tyStateRefined :: TyState -> TyState -> Bool+-- Makes use of the fact that the two TyStates we compare will never have the+-- same sequence number. It is invalid to call this function when a is not a+-- refinement of b or vice versa!+tyStateRefined a b = ty_st_n a /= ty_st_n b++markDirty :: Id -> Nabla -> Nabla+markDirty x nabla@MkNabla{nabla_tm_st = ts@TmSt{ts_dirty = dirty} } =+ nabla{ nabla_tm_st = ts{ ts_dirty = extendDVarSet dirty x } }++traverseDirty :: Monad m => (VarInfo -> m VarInfo) -> TmState -> m TmState+traverseDirty f ts@TmSt{ts_facts = env, ts_dirty = dirty} =+ go (uniqDSetToList dirty) env+ where+ go [] env = pure ts{ts_facts=env}+ go (x:xs) !env = do+ vi' <- f (lookupVarInfo ts x)+ go xs (addToUSDFM env x vi')++traverseAll :: Monad m => (VarInfo -> m VarInfo) -> TmState -> m TmState+traverseAll f ts@TmSt{ts_facts = env} = do+ env' <- traverseUSDFM f env+ pure ts{ts_facts = env'}++-- | Makes sure the given 'Nabla' is still inhabited, by trying to instantiate+-- all dirty variables (or all variables when the 'TyState' changed) to concrete+-- inhabitants. It returns a 'Nabla' with the *same* inhabitants, but with some+-- amount of work cached (like failed instantiation attempts) from the test.+--+-- The \(∇ ⊢ x inh\) judgment form in Figure 8 of the LYG paper.+inhabitationTest :: Int -> TyState -> Nabla -> MaybeT DsM Nabla+inhabitationTest 0 _ nabla = pure nabla+inhabitationTest fuel old_ty_st nabla@MkNabla{ nabla_tm_st = ts } = do+ -- lift $ tracePm "inhabitation test" $ vcat+ -- [ ppr fuel+ -- , ppr old_ty_st+ -- , ppr nabla+ -- , text "tyStateRefined:" <+> ppr (tyStateRefined old_ty_st (nabla_ty_st nabla))+ -- ]+ -- When type state didn't change, we only need to traverse dirty VarInfos+ ts' <- if tyStateRefined old_ty_st (nabla_ty_st nabla)+ then traverseAll test_one ts+ else traverseDirty test_one ts+ pure nabla{ nabla_tm_st = ts'{ts_dirty=emptyDVarSet}}+ where+ nabla_not_dirty = nabla{ nabla_tm_st = ts{ts_dirty=emptyDVarSet} }+ test_one :: VarInfo -> MaybeT DsM VarInfo+ test_one vi = do+ lift (varNeedsTesting old_ty_st nabla vi) >>= \case+ True -> do+ -- tracPm "test_one" (ppr vi)+ -- No solution yet and needs testing+ -- We have to test with a Nabla where all dirty bits are cleared+ instantiate (fuel-1) nabla_not_dirty vi+ _ -> pure vi++-- | Checks whether the given 'VarInfo' needs to be tested for inhabitants.+--+-- 1. If it already has a solution, we don't have to test.+-- 2. If it's marked dirty because of new negative term constraints, we have+-- to test.+-- 3. Otherwise, if the type state didn't change, we don't need to test.+-- 4. If the type state changed, we compare normalised source types. No need+-- to test if unchanged.+varNeedsTesting :: TyState -> Nabla -> VarInfo -> DsM Bool+varNeedsTesting _ _ vi+ | notNull (vi_pos vi) = pure False+varNeedsTesting _ MkNabla{nabla_tm_st=tm_st} vi+ | elemDVarSet (vi_id vi) (ts_dirty tm_st) = pure True+varNeedsTesting old_ty_st MkNabla{nabla_ty_st=new_ty_st} _+ -- Same type state => still inhabited+ | not (tyStateRefined old_ty_st new_ty_st) = pure False+varNeedsTesting old_ty_st MkNabla{nabla_ty_st=new_ty_st} vi = do+ -- These normalisations are relatively expensive, but still better than having+ -- to perform a full inhabitation test+ (_, _, old_norm_ty) <- tntrGuts <$> pmTopNormaliseType old_ty_st (idType $ vi_id vi)+ (_, _, new_norm_ty) <- tntrGuts <$> pmTopNormaliseType new_ty_st (idType $ vi_id vi)+ if old_norm_ty `eqType` new_norm_ty+ then pure False+ else pure True++-- | Returns (Just vi) if at least one member of each ConLike in the COMPLETE+-- set satisfies the oracle+--+-- Internally uses and updates the ConLikeSets in vi_rcm.+--+-- NB: Does /not/ filter each ConLikeSet with the oracle; members may+-- remain that do not statisfy it. This lazy approach just+-- avoids doing unnecessary work.+instantiate :: Int -> Nabla -> VarInfo -> MaybeT DsM VarInfo+instantiate fuel nabla vi = instBot fuel nabla vi <|> instCompleteSets fuel nabla vi++-- | The \(⊢_{Bot}\) rule from the paper+instBot :: Int -> Nabla -> VarInfo -> MaybeT DsM VarInfo+instBot _fuel nabla vi = do+ _nabla' <- addBotCt nabla (vi_id vi)+ pure vi++addNormalisedTypeMatches :: Nabla -> Id -> DsM (ResidualCompleteMatches, Nabla)+addNormalisedTypeMatches nabla@MkNabla{ nabla_ty_st = ty_st } x+ = trvVarInfo add_matches nabla x+ where+ add_matches vi@VI{ vi_rcm = rcm }+ -- important common case, shaving down allocations of PmSeriesG by -5%+ | isRcmInitialised rcm = pure (rcm, vi)+ add_matches vi@VI{ vi_rcm = rcm } = do+ norm_res_ty <- normaliseSourceTypeWHNF ty_st (idType x)+ env <- dsGetFamInstEnvs+ rcm' <- case splitReprTyConApp_maybe env norm_res_ty of+ Just (rep_tc, _args, _co) -> addTyConMatches rep_tc rcm+ Nothing -> addCompleteMatches rcm+ pure (rcm', vi{ vi_rcm = rcm' })++-- | Does a 'splitTyConApp_maybe' and then tries to look through a data family+-- application to find the representation TyCon, to which the data constructors+-- are attached. Returns the representation TyCon, the TyCon application args+-- and a representational coercion that will be Refl for non-data family apps.+splitReprTyConApp_maybe :: FamInstEnvs -> Type -> Maybe (TyCon, [Type], Coercion)+splitReprTyConApp_maybe env ty =+ uncurry (tcLookupDataFamInst env) <$> splitTyConApp_maybe ty++-- | This is the |-Inst rule from the paper (section 4.5). Tries to+-- find an inhabitant in every complete set by instantiating with one their+-- constructors. If there is any complete set where we can't find an+-- inhabitant, the whole thing is uninhabited. It returns the updated 'VarInfo'+-- where all the attempted ConLike instantiations have been purged from the+-- 'ResidualCompleteMatches', which functions as a cache.+instCompleteSets :: Int -> Nabla -> VarInfo -> MaybeT DsM VarInfo+instCompleteSets fuel nabla vi = do+ let x = vi_id vi+ (rcm, nabla) <- lift (addNormalisedTypeMatches nabla x)+ nabla <- foldM (\nabla cls -> instCompleteSet fuel nabla x cls) nabla (getRcm rcm)+ pure (lookupVarInfo (nabla_tm_st nabla) x)++anyConLikeSolution :: (ConLike -> Bool) -> [PmAltConApp] -> Bool+anyConLikeSolution p = any (go . paca_con)+ where+ go (PmAltConLike cl) = p cl+ go _ = False++-- | @instCompleteSet fuel nabla nabla cls@ iterates over @cls@ until it finds+-- the first inhabited ConLike (as per 'instCon'). Any failed instantiation+-- attempts of a ConLike are recorded as negative information in the returned+-- 'Nabla', so that later calls to this function can skip repeatedly fruitless+-- instantiation of that same constructor.+--+-- Note that the returned Nabla is just a different representation of the+-- original Nabla, not a proper refinement! No positive information will be+-- added, only negative information from failed instantiation attempts,+-- entirely as an optimisation.+instCompleteSet :: Int -> Nabla -> Id -> ConLikeSet -> MaybeT DsM Nabla+instCompleteSet fuel nabla x cs+ | anyConLikeSolution (`elementOfUniqDSet` cs) (vi_pos vi)+ -- No need to instantiate a constructor of this COMPLETE set if we already+ -- have a solution!+ = pure nabla+ | otherwise+ = go nabla (sorted_candidates cs)+ where+ vi = lookupVarInfo (nabla_tm_st nabla) x++ sorted_candidates :: ConLikeSet -> [ConLike]+ sorted_candidates cs+ -- If there aren't many candidates, we can try to sort them by number of+ -- strict fields, type constraints, etc., so that we are fast in the+ -- common case+ -- (either many simple constructors *or* few "complicated" ones).+ | sizeUniqDSet cs <= 5 = sortBy compareConLikeTestability (uniqDSetToList cs)+ | otherwise = uniqDSetToList cs++ go :: Nabla -> [ConLike] -> MaybeT DsM Nabla+ go _ [] = mzero+ go nabla (RealDataCon dc:_)+ -- See Note [DataCons that are definitely inhabitable]+ -- Recall that dc can't be in vi_neg, because then it would be+ -- deleted from the residual COMPLETE set.+ | isDataConTriviallyInhabited dc+ = pure nabla+ go nabla (con:cons) = do+ let x = vi_id vi+ let recur_not_con = do+ nabla' <- addNotConCt nabla x (PmAltConLike con)+ go nabla' cons+ (nabla <$ instCon fuel nabla x con) -- return the original nabla, not the+ -- refined one!+ <|> recur_not_con -- Assume that x can't be con. Encode that fact+ -- with addNotConCt and recur.++-- | Is this 'DataCon' trivially inhabited, that is, without needing to perform+-- any inhabitation testing because of strict/unlifted fields or type+-- equalities? See Note [DataCons that are definitely inhabitable]+isDataConTriviallyInhabited :: DataCon -> Bool+isDataConTriviallyInhabited dc+ | isTyConTriviallyInhabited (dataConTyCon dc) = True+isDataConTriviallyInhabited dc =+ null (dataConTheta dc) && -- (1)+ null (dataConImplBangs dc) && -- (2)+ null (dataConUnliftedFieldTys dc) -- (3)++dataConUnliftedFieldTys :: DataCon -> [Type]+dataConUnliftedFieldTys =+ -- A levity polymorphic field requires an inhabitation test, hence compare to+ -- @Just True@+ filter ((== Just True) . isLiftedType_maybe) . map scaledThing . dataConOrigArgTys++isTyConTriviallyInhabited :: TyCon -> Bool+isTyConTriviallyInhabited tc = elementOfUniqSet tc triviallyInhabitedTyCons++-- | All these types are trivially inhabited+triviallyInhabitedTyCons :: UniqSet TyCon+triviallyInhabitedTyCons = mkUniqSet [+ charTyCon, doubleTyCon, floatTyCon, intTyCon, wordTyCon, word8TyCon+ ]++compareConLikeTestability :: ConLike -> ConLike -> Ordering+-- We should instantiate DataCons first, because they are likely to occur in+-- multiple COMPLETE sets at once and we might find that multiple COMPLETE sets+-- are inhabitated by instantiating only a single DataCon.+compareConLikeTestability PatSynCon{} _ = GT+compareConLikeTestability _ PatSynCon{} = GT+compareConLikeTestability (RealDataCon a) (RealDataCon b) = mconcat+ -- Thetas are most expensive to check, as they might incur a whole new round+ -- of inhabitation testing+ [ comparing (fast_length . dataConTheta)+ -- Unlifted or strict fields only incur an inhabitation test for that+ -- particular field. Still something to avoid.+ , comparing unlifted_or_strict_fields+ ] a b+ where+ fast_length :: [a] -> Int+ fast_length xs = atLength length 6 xs 5 -- @min 6 (length xs)@, but O(1)++ -- An upper bound on the number of strict or unlifted fields. Approximate in+ -- the unlikely bogus case of an unlifted field that has a bang.+ unlifted_or_strict_fields :: DataCon -> Int+ unlifted_or_strict_fields dc = fast_length (dataConImplBangs dc)+ + fast_length (dataConUnliftedFieldTys dc)++-- | @instCon fuel nabla (x::res_ty) K@ tries to instantiate @x@ to @K@.+-- This is the \(Inst\) function from Figure 8 of the LYG paper.+--+-- As a first step, it tries to guess the universal type arguments of @K@ from+-- the @res_ty@ and @K@'s result type, so that we have+--+-- K @arg_tys :: forall es. Q => t1 -> ... -> tn -> res_ty+--+-- See 'guessConLikeUnivTyArgsFromResTy' for when it might fail to guess (only+-- for certain pattern synonyms).+-- If the function /fails/ to guess, 'instCon' trivially succeeds, because it+-- can't be sure if @x@ could be instantiated to @K@ and has to be+-- conservative).+-- If the function /succeeds/ in guessing @arg_tys@, it does the necessary+-- substitution and instantiation dance for @K@'s field types, which may still+-- reference existential type variables of @K@. So it performs the following steps:+--+-- * It accumulates a substitution mapping @K@'s universal type variables,+-- which are substituted for @arg_tys@.+-- * It instantiates fresh binders for the other type variables @es@ bound by+-- @K@ and adds it to the substitution, so that we have+-- @K \@arg_tys \@ex_tvs :: Q => t1' -> ... -> tn' -> res_ty@+-- * It substitutes the 'ThetaType' @Q@ for type constraints @gammas@ to add+-- * It substitutes and conjures new binders @arg_ids@ for the argument types+-- @t1' ... tn'@.+--+-- Finally, it adds a 'PhiConCt' constructor constraint+-- @K ex_tvs gammas arg_ids <- x@ which handles the details regarding type+-- constraints and unlifted fields.+instCon :: Int -> Nabla -> Id -> ConLike -> MaybeT DsM Nabla+instCon fuel nabla@MkNabla{nabla_ty_st = ty_st} x con = MaybeT $ do+ env <- dsGetFamInstEnvs+ let res_ty = idType x+ norm_res_ty <- normaliseSourceTypeWHNF ty_st res_ty+ let mb_arg_tys = guessConLikeUnivTyArgsFromResTy env norm_res_ty con+ case mb_arg_tys of+ Just arg_tys -> do+ let (univ_tvs, ex_tvs, eq_spec, thetas, _req_theta, field_tys, _con_res_ty)+ = conLikeFullSig con+ -- (1) Substitute universals for type arguments+ let subst_univ = zipTvSubst univ_tvs arg_tys+ -- (2) Instantiate fresh existentials as arguments to the constructor.+ -- This is important for instantiating the Thetas and field types.+ (subst, _) <- cloneTyVarBndrs subst_univ ex_tvs <$> getUniqueSupplyM+ let field_tys' = substTys subst $ map scaledThing field_tys+ -- (3) All constraints bound by the constructor (alpha-renamed), these are added+ -- to the type oracle+ let gammas = substTheta subst (eqSpecPreds eq_spec ++ thetas)+ -- (4) Instantiate fresh term variables as arguments to the constructor+ arg_ids <- mapM mkPmId field_tys'+ tracePm "instCon" $ vcat+ [ ppr x <+> dcolon <+> ppr res_ty+ , text "In WHNF:" <+> ppr (isSourceTypeInWHNF res_ty) <+> ppr norm_res_ty+ , ppr con <+> dcolon <+> text "... ->" <+> ppr _con_res_ty+ , ppr (zipWith (\tv ty -> ppr tv <+> char '↦' <+> ppr ty) univ_tvs arg_tys)+ , ppr gammas+ , ppr (map (\x -> ppr x <+> dcolon <+> ppr (idType x)) arg_ids)+ , ppr fuel+ ]+ -- Finally add the constraint+ runMaybeT $ do+ -- Case (2) of Note [Strict fields and variables of unlifted type]+ let alt = PmAltConLike con+ nabla' <- addPhiTmCt nabla (PhiConCt x alt ex_tvs gammas arg_ids)+ let branching_factor = length $ filterUnliftedFields alt arg_ids+ -- See Note [Fuel for the inhabitation test]+ let new_fuel+ | branching_factor <= 1 = fuel+ | otherwise = min fuel 2+ inhabitationTest new_fuel (nabla_ty_st nabla) nabla'+ Nothing -> pure (Just nabla) -- Could not guess arg_tys. Just assume inhabited++-- | Guess the universal argument types of a ConLike from an instantiation of+-- its (normalised!) result type. So, given+--+-- K :: forall us. forall es. Q => t1 -> ... -> tn -> con_res_ty+--+-- It tries to guess @arg_tys@ by matching @norm_res_ty@ and @con_res_ty@, such that+--+-- K @arg_tys :: forall es. Q' => t1' -> ... -> tn' -> norm_res_ty+--+-- Rather easy for DataCons, but not so much for PatSynCons. See Note [Pattern+-- synonym result type] in "GHC.Core.PatSyn".+guessConLikeUnivTyArgsFromResTy :: FamInstEnvs -> Type -> ConLike -> Maybe [Type]+guessConLikeUnivTyArgsFromResTy env norm_res_ty (RealDataCon dc) = do+ -- splitReprTyConApp_maybe rather than splitTyConApp_maybe because of data families.+ (rep_tc, tc_args, _co) <- splitReprTyConApp_maybe env norm_res_ty+ if rep_tc == dataConTyCon dc+ then Just tc_args+ else Nothing+guessConLikeUnivTyArgsFromResTy _ norm_res_ty (PatSynCon ps) = do+ -- We are successful if we managed to instantiate *every* univ_tv of con.+ -- This is difficult and bound to fail in some cases, see+ -- Note [Pattern synonym result type] in GHC.Core.PatSyn. So we just try our best+ -- here and be sure to return an instantiation when we can substitute every+ -- universally quantified type variable.+ -- We *could* instantiate all the other univ_tvs just to fresh variables, I+ -- suppose, but that means we get weird field types for which we don't know+ -- anything. So we prefer to keep it simple here.+ let (univ_tvs,_,_,_,_,con_res_ty) = patSynSig ps+ subst <- tcMatchTy con_res_ty norm_res_ty+ traverse (lookupTyVar subst) univ_tvs++{- Note [Fuel for the inhabitation test]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Whether or not a type is inhabited is undecidable in general. As a result, we+can run into infinite loops in `inhabitationTest`. Therefore, we adopt a+fuel-based approach to prevent that.++Consider the following example:++ data Abyss = MkAbyss !Abyss+ stareIntoTheAbyss :: Abyss -> a+ stareIntoTheAbyss x = case x of {}++In principle, stareIntoTheAbyss is exhaustive, since there is no way to+construct a terminating value using MkAbyss. But this can't be proven by mere+instantiation and requires an inductive argument, which `inhabitationTest`+currently isn't equipped to do.++In order to prevent endless instantiation attempts in @inhabitationTest@, we+use the fuel as an upper bound such attempts.++The same problem occurs with recursive newtypes, like in the following code:++ newtype Chasm = MkChasm Chasm+ gazeIntoTheChasm :: Chasm -> a+ gazeIntoTheChasm x = case x of {} -- Erroneously warned as non-exhaustive++So this limitation is somewhat understandable.++Note that even with this recursion detection, there is still a possibility that+`inhabitationTest` can run in exponential time in the amount of fuel. Consider+the following data type:++ data T = MkT !T !T !T++If we try to instantiate each of its fields, that will require us to once again+check if `MkT` is inhabitable in each of those three fields, which in turn will+require us to check if `MkT` is inhabitable again... As you can see, the+branching factor adds up quickly, and if the initial fuel is, say,+100, then the inhabiation test will effectively take forever.++To mitigate this, we check the branching factor every time we are about to do+inhabitation testing in 'instCon'. If the branching factor exceeds 1+(i.e., if there is potential for exponential runtime), then we limit the+maximum recursion depth to 1 to mitigate the problem. If the branching factor+is exactly 1 (i.e., we have a linear chain instead of a tree), then it's okay+to stick with a larger maximum recursion depth.++In #17977 we saw that the defaultRecTcMaxBound (100 at the time of writing) was+too large and had detrimental effect on performance of the coverage checker.+Given that we only commit to a best effort anyway, we decided to substantially+decrement the fuel to 4, at the cost of precision in some edge cases+like++ data Nat = Z | S Nat+ data Down :: Nat -> Type where+ Down :: !(Down n) -> Down (S n)+ f :: Down (S (S (S (S (S Z))))) -> ()+ f x = case x of {}++Since the coverage won't bother to instantiate Down 4 levels deep to see that it+is in fact uninhabited, it will emit a inexhaustivity warning for the case.++Note [DataCons that are definitely inhabitable]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Another microoptimization applies to data types like this one:++ data S a = S ![a] !T++Even though there is a strict field of type [a], it's quite silly to call+'instCon' on it, since it's "obvious" that it is inhabitable. To make this+intuition formal, we say that a DataCon C is definitely inhabitable (DI) if:++ 1. C has no equality constraints (since they might be unsatisfiable)+ 2. C has no strict arguments (since they might be uninhabitable)+ 3. C has no unlifted argument types (since they might be uninhabitable)++It's relatively cheap to check if a DataCon is DI, so before we call 'instCon'+on a constructor of a COMPLETE set, we filter out all of the DI ones.++This fast path shaves down -7% allocations for PmSeriesG, for example.+-}++--------------------------------------+-- * Generating inhabitants of a Nabla+--+-- This is important for warnings. Roughly corresponds to G in Figure 6 of the+-- LYG paper, with a few tweaks for better warning messages.++-- | @generateInhabitingPatterns vs n nabla@ returns a list of at most @n@ (but+-- perhaps empty) refinements of @nabla@ that represent inhabited patterns.+-- Negative information is only retained if literals are involved or for+-- recursive GADTs.+generateInhabitingPatterns :: [Id] -> Int -> Nabla -> DsM [Nabla]+-- See Note [Why inhabitationTest doesn't call generateInhabitingPatterns]+generateInhabitingPatterns _ 0 _ = pure []+generateInhabitingPatterns [] _ nabla = pure [nabla]+generateInhabitingPatterns (x:xs) n nabla = do+ tracePm "generateInhabitingPatterns" (ppr n <+> ppr (x:xs) $$ ppr nabla)+ let VI _ pos neg _ _ = lookupVarInfo (nabla_tm_st nabla) x+ case pos of+ _:_ -> do+ -- All solutions must be valid at once. Try to find candidates for their+ -- fields. Example:+ -- f x@(Just _) True = case x of SomePatSyn _ -> ()+ -- after this clause, we want to report that+ -- * @f Nothing _@ is uncovered+ -- * @f x False@ is uncovered+ -- where @x@ will have two possibly compatible solutions, @Just y@ for+ -- some @y@ and @SomePatSyn z@ for some @z@. We must find evidence for @y@+ -- and @z@ that is valid at the same time. These constitute arg_vas below.+ let arg_vas = concatMap paca_ids pos+ generateInhabitingPatterns (arg_vas ++ xs) n nabla+ []+ -- When there are literals involved, just print negative info+ -- instead of listing missed constructors+ | notNull [ l | PmAltLit l <- pmAltConSetElems neg ]+ -> generateInhabitingPatterns xs n nabla+ [] -> try_instantiate x xs n nabla+ where+ -- | Tries to instantiate a variable by possibly following the chain of+ -- newtypes and then instantiating to all ConLikes of the wrapped type's+ -- minimal residual COMPLETE set.+ try_instantiate :: Id -> [Id] -> Int -> Nabla -> DsM [Nabla]+ -- Convention: x binds the outer constructor in the chain, y the inner one.+ try_instantiate x xs n nabla = do+ (_src_ty, dcs, rep_ty) <- tntrGuts <$> pmTopNormaliseType (nabla_ty_st nabla) (idType x)+ mb_stuff <- runMaybeT $ instantiate_newtype_chain x nabla dcs+ case mb_stuff of+ Nothing -> pure []+ Just (y, newty_nabla) -> do+ let vi = lookupVarInfo (nabla_tm_st newty_nabla) y+ env <- dsGetFamInstEnvs+ rcm <- case splitReprTyConApp_maybe env rep_ty of+ Just (tc, _, _) -> addTyConMatches tc (vi_rcm vi)+ Nothing -> addCompleteMatches (vi_rcm vi)++ -- Test all COMPLETE sets for inhabitants (n inhs at max). Take care of ⊥.+ clss <- pickApplicableCompleteSets rep_ty rcm+ case NE.nonEmpty (uniqDSetToList <$> clss) of+ Nothing ->+ -- No COMPLETE sets ==> inhabited+ generateInhabitingPatterns xs n newty_nabla+ Just clss -> do+ -- Try each COMPLETE set, pick the one with the smallest number of+ -- inhabitants+ nablass' <- forM clss (instantiate_cons y rep_ty xs n newty_nabla)+ let nablas' = minimumBy (comparing length) nablass'+ if null nablas' && vi_bot vi /= IsNotBot+ then generateInhabitingPatterns xs n newty_nabla -- bot is still possible. Display a wildcard!+ else pure nablas'++ -- | Instantiates a chain of newtypes, beginning at @x@.+ -- Turns @x nabla [T,U,V]@ to @(y, nabla')@, where @nabla'@ we has the fact+ -- @x ~ T (U (V y))@.+ instantiate_newtype_chain :: Id -> Nabla -> [(Type, DataCon, Type)] -> MaybeT DsM (Id, Nabla)+ instantiate_newtype_chain x nabla [] = pure (x, nabla)+ instantiate_newtype_chain x nabla ((_ty, dc, arg_ty):dcs) = do+ y <- lift $ mkPmId arg_ty+ -- Newtypes don't have existentials (yet?!), so passing an empty+ -- list as ex_tvs.+ nabla' <- addConCt nabla x (PmAltConLike (RealDataCon dc)) [] [y]+ instantiate_newtype_chain y nabla' dcs++ instantiate_cons :: Id -> Type -> [Id] -> Int -> Nabla -> [ConLike] -> DsM [Nabla]+ instantiate_cons _ _ _ _ _ [] = pure []+ instantiate_cons _ _ _ 0 _ _ = pure []+ instantiate_cons _ ty xs n nabla _+ -- We don't want to expose users to GHC-specific constructors for Int etc.+ | fmap (isTyConTriviallyInhabited . fst) (splitTyConApp_maybe ty) == Just True+ = generateInhabitingPatterns xs n nabla+ instantiate_cons x ty xs n nabla (cl:cls) = do+ -- The following line is where we call out to the inhabitationTest!+ mb_nabla <- runMaybeT $ instCon 4 nabla x cl+ tracePm "instantiate_cons" (vcat [ ppr x <+> dcolon <+> ppr (idType x)+ , ppr ty+ , ppr cl+ , ppr nabla+ , ppr mb_nabla+ , ppr n ])+ con_nablas <- case mb_nabla of+ Nothing -> pure []+ -- NB: We don't prepend arg_vars as we don't have any evidence on+ -- them and we only want to split once on a data type. They are+ -- inhabited, otherwise the inhabitation test would have refuted.+ Just nabla' -> generateInhabitingPatterns xs n nabla'+ other_cons_nablas <- instantiate_cons x ty xs (n - length con_nablas) nabla cls+ pure (con_nablas ++ other_cons_nablas)++pickApplicableCompleteSets :: Type -> ResidualCompleteMatches -> DsM [ConLikeSet]+pickApplicableCompleteSets ty rcm = do+ env <- dsGetFamInstEnvs+ pure $ filter (all (is_valid env) . uniqDSetToList) (getRcm rcm)+ where+ is_valid :: FamInstEnvs -> ConLike -> Bool+ is_valid env cl = isJust (guessConLikeUnivTyArgsFromResTy env ty cl)++{- Note [Why inhabitationTest doesn't call generateInhabitingPatterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Why can't we define `inhabitationTest` (IT) in terms of+`generateInhabitingPatterns` (GIP) as++ inhabitationTest nabla = do+ nablas <- lift $ generateInhabitingPatterns all_variables 1 nabla+ guard (notNull nablas)++There are a few technical reasons, like the lack of a fuel-tracking approach+to stay decidable, that could be overcome. But the nail in the coffin is+performance: In order to provide good warning messages, GIP commits to *one*+COMPLETE set, and goes through some hoops to find the minimal one. This implies+it has to look at *all* constructors in the residual COMPLETE matches and see if+they match, if only to filter out ill-typed COMPLETE sets+(see Note [Implementation of COMPLETE pragmas]). That is untractable for an+efficient IT on huge enumerations.++But we still need GIP to produce the Nablas as proxies for+uncovered patterns that we display warnings for. It's fine to pay this price+once at the end, but IT is called far more often than that.+-}
+ compiler/GHC/HsToCore/Pmc/Solver/Types.hs view
@@ -0,0 +1,639 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ApplicativeDo #-}++-- | Domain types used in "GHC.HsToCore.Pmc.Solver".+-- The ultimate goal is to define 'Nabla', which models normalised refinement+-- types from the paper+-- [Lower Your Guards: A Compositional Pattern-Match Coverage Checker"](https://dl.acm.org/doi/abs/10.1145/3408989).+module GHC.HsToCore.Pmc.Solver.Types (++ -- * Normalised refinement types+ BotInfo(..), PmAltConApp(..), VarInfo(..), TmState(..), TyState(..),+ Nabla(..), Nablas(..), initNablas,++ -- ** Caching residual COMPLETE sets+ ConLikeSet, ResidualCompleteMatches(..), getRcm, isRcmInitialised,++ -- ** Representations for Literals and AltCons+ PmLit(..), PmLitValue(..), PmAltCon(..), pmLitType, pmAltConType,+ isPmAltConMatchStrict, pmAltConImplBangs,++ -- *** PmAltConSet+ PmAltConSet, emptyPmAltConSet, isEmptyPmAltConSet, elemPmAltConSet,+ extendPmAltConSet, pmAltConSetElems,++ -- *** Equality on 'PmAltCon's+ PmEquality(..), eqPmAltCon,++ -- *** Operations on 'PmLit'+ literalToPmLit, negatePmLit, overloadPmLit,+ pmLitAsStringLit, coreExprAsPmLit++ ) where++#include "GhclibHsVersions.h"++import GHC.Prelude++import GHC.Utils.Misc+import GHC.Data.Bag+import GHC.Data.FastString+import GHC.Types.Id+import GHC.Types.Var.Set+import GHC.Types.Unique.DSet+import GHC.Types.Unique.SDFM+import GHC.Types.Name+import GHC.Core.DataCon+import GHC.Core.ConLike+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Data.List.SetOps (unionLists)+import GHC.Data.Maybe+import GHC.Core.Type+import GHC.Core.TyCon+import GHC.Types.Literal+import GHC.Core+import GHC.Core.Map+import GHC.Core.Utils (exprType)+import GHC.Builtin.Names+import GHC.Builtin.Types+import GHC.Builtin.Types.Prim+import GHC.Tc.Solver.Monad (InertSet, emptyInert)+import GHC.Tc.Utils.TcType (isStringTy)+import GHC.Driver.Types (ConLikeSet)++import Numeric (fromRat)+import Data.Foldable (find)+import Data.Ratio+import qualified Data.Semigroup as Semi++--+-- * Normalised refinement types+--++-- | A normalised refinement type ∇ (\"nabla\"), comprised of an inert set of+-- canonical (i.e. mutually compatible) term and type constraints that form the+-- refinement type's predicate.+data Nabla+ = MkNabla+ { nabla_ty_st :: !TyState+ -- ^ Type oracle; things like a~Int+ , nabla_tm_st :: !TmState+ -- ^ Term oracle; things like x~Nothing+ }++-- | An initial nabla that is always satisfiable+initNabla :: Nabla+initNabla = MkNabla initTyState initTmState++instance Outputable Nabla where+ ppr nabla = hang (text "Nabla") 2 $ vcat [+ -- intentionally formatted this way enable the dev to comment in only+ -- the info she needs+ ppr (nabla_tm_st nabla),+ ppr (nabla_ty_st nabla)+ ]++-- | A disjunctive bag of 'Nabla's, representing a refinement type.+newtype Nablas = MkNablas (Bag Nabla)++initNablas :: Nablas+initNablas = MkNablas (unitBag initNabla)++instance Outputable Nablas where+ ppr (MkNablas nablas) = ppr nablas++instance Semigroup Nablas where+ MkNablas l <> MkNablas r = MkNablas (l `unionBags` r)++instance Monoid Nablas where+ mempty = MkNablas emptyBag++-- | The type oracle state. An 'GHC.Tc.Solver.Monad.InertSet' that we+-- incrementally add local type constraints to, together with a sequence+-- number that counts the number of times we extended it with new facts.+data TyState = TySt { ty_st_n :: !Int, ty_st_inert :: !InertSet }++-- | Not user-facing.+instance Outputable TyState where+ ppr (TySt n inert) = ppr n <+> ppr inert++initTyState :: TyState+initTyState = TySt 0 emptyInert++-- | The term oracle state. Stores 'VarInfo' for encountered 'Id's. These+-- entries are possibly shared when we figure out that two variables must be+-- equal, thus represent the same set of values.+--+-- See Note [TmState invariants] in "GHC.HsToCore.Pmc.Solver".+data TmState+ = TmSt+ { ts_facts :: !(UniqSDFM Id VarInfo)+ -- ^ Facts about term variables. Deterministic env, so that we generate+ -- deterministic error messages.+ , ts_reps :: !(CoreMap Id)+ -- ^ An environment for looking up whether we already encountered semantically+ -- equivalent expressions that we want to represent by the same 'Id'+ -- representative.+ , ts_dirty :: !DIdSet+ -- ^ Which 'VarInfo' needs to be checked for inhabitants because of new+ -- negative constraints (e.g. @x ≁ ⊥@ or @x ≁ K@).+ }++-- | Information about an 'Id'. Stores positive ('vi_pos') facts, like @x ~ Just 42@,+-- and negative ('vi_neg') facts, like "x is not (:)".+-- Also caches the type ('vi_ty'), the 'ResidualCompleteMatches' of a COMPLETE set+-- ('vi_rcm').+--+-- Subject to Note [The Pos/Neg invariant] in "GHC.HsToCore.Pmc.Solver".+data VarInfo+ = VI+ { vi_id :: !Id+ -- ^ The 'Id' in question. Important for adding new constraints relative to+ -- this 'VarInfo' when we don't easily have the 'Id' available.++ , vi_pos :: ![PmAltConApp]+ -- ^ Positive info: 'PmAltCon' apps it is (i.e. @x ~ [Just y, PatSyn z]@), all+ -- at the same time (i.e. conjunctive). We need a list because of nested+ -- pattern matches involving pattern synonym+ -- case x of { Just y -> case x of PatSyn z -> ... }+ -- However, no more than one RealDataCon in the list, otherwise contradiction+ -- because of generativity.++ , vi_neg :: !PmAltConSet+ -- ^ Negative info: A list of 'PmAltCon's that it cannot match.+ -- Example, assuming+ --+ -- @+ -- data T = Leaf Int | Branch T T | Node Int T+ -- @+ --+ -- then @x ≁ [Leaf, Node]@ means that @x@ cannot match a @Leaf@ or @Node@,+ -- and hence can only match @Branch@. Is orthogonal to anything from 'vi_pos',+ -- in the sense that 'eqPmAltCon' returns @PossiblyOverlap@ for any pairing+ -- between 'vi_pos' and 'vi_neg'.++ -- See Note [Why record both positive and negative info?]+ -- It's worth having an actual set rather than a simple association list,+ -- because files like Cabal's `LicenseId` define relatively huge enums+ -- that lead to quadratic or worse behavior.++ , vi_bot :: BotInfo+ -- ^ Can this variable be ⊥? Models (mutually contradicting) @x ~ ⊥@ and+ -- @x ≁ ⊥@ constraints. E.g.+ -- * 'MaybeBot': Don't know; Neither @x ~ ⊥@ nor @x ≁ ⊥@.+ -- * 'IsBot': @x ~ ⊥@+ -- * 'IsNotBot': @x ≁ ⊥@++ , vi_rcm :: !ResidualCompleteMatches+ -- ^ A cache of the associated COMPLETE sets. At any time a superset of+ -- possible constructors of each COMPLETE set. So, if it's not in here, we+ -- can't possibly match on it. Complementary to 'vi_neg'. We still need it+ -- to recognise completion of a COMPLETE set efficiently for large enums.+ }++data PmAltConApp+ = PACA+ { paca_con :: !PmAltCon+ , paca_tvs :: ![TyVar]+ , paca_ids :: ![Id]+ }++-- | See 'vi_bot'.+data BotInfo+ = IsBot+ | IsNotBot+ | MaybeBot+ deriving Eq++instance Outputable PmAltConApp where+ ppr PACA{paca_con = con, paca_tvs = tvs, paca_ids = ids} =+ hsep (ppr con : map ((char '@' <>) . ppr) tvs ++ map ppr ids)++instance Outputable BotInfo where+ ppr MaybeBot = underscore+ ppr IsBot = text "~⊥"+ ppr IsNotBot = text "≁⊥"++-- | Not user-facing.+instance Outputable TmState where+ ppr (TmSt state reps dirty) = ppr state $$ ppr reps $$ ppr dirty++-- | Not user-facing.+instance Outputable VarInfo where+ ppr (VI x pos neg bot cache)+ = braces (hcat (punctuate comma [pp_x, pp_pos, pp_neg, ppr bot, pp_cache]))+ where+ pp_x = ppr x <> dcolon <> ppr (idType x)+ pp_pos+ | [] <- pos = underscore+ | [p] <- pos = char '~' <> ppr p -- suppress outer [_] if singleton+ | otherwise = char '~' <> ppr pos+ pp_neg+ | isEmptyPmAltConSet neg = underscore+ | otherwise = char '≁' <> ppr neg+ pp_cache+ | RCM Nothing Nothing <- cache = underscore+ | otherwise = ppr cache++-- | Initial state of the term oracle.+initTmState :: TmState+initTmState = TmSt emptyUSDFM emptyCoreMap emptyDVarSet++-- | A data type that caches for the 'VarInfo' of @x@ the results of querying+-- 'dsGetCompleteMatches' and then striking out all occurrences of @K@ for+-- which we already know @x ≁ K@ from these sets.+--+-- For motivation, see Section 5.3 in Lower Your Guards.+-- See also Note [Implementation of COMPLETE pragmas]+data ResidualCompleteMatches+ = RCM+ { rcm_vanilla :: !(Maybe ConLikeSet)+ -- ^ The residual set for the vanilla COMPLETE set from the data defn.+ -- Tracked separately from 'rcm_pragmas', because it might only be+ -- known much later (when we have enough type information to see the 'TyCon'+ -- of the match), or not at all even. Until that happens, it is 'Nothing'.+ , rcm_pragmas :: !(Maybe [ConLikeSet])+ -- ^ The residual sets for /all/ COMPLETE sets from pragmas that are+ -- visible when compiling this module. Querying that set with+ -- 'dsGetCompleteMatches' requires 'DsM', so we initialise it with 'Nothing'+ -- until first needed in a 'DsM' context.+ }++getRcm :: ResidualCompleteMatches -> [ConLikeSet]+getRcm (RCM vanilla pragmas) = maybeToList vanilla ++ fromMaybe [] pragmas++isRcmInitialised :: ResidualCompleteMatches -> Bool+isRcmInitialised (RCM vanilla pragmas) = isJust vanilla && isJust pragmas++instance Outputable ResidualCompleteMatches where+ -- formats as "[{Nothing,Just},{P,Q}]"+ ppr rcm = ppr (getRcm rcm)++--------------------------------------------------------------------------------+-- The rest is just providing an IR for (overloaded!) literals and AltCons that+-- sits between Hs and Core. We need a reliable way to detect and determine+-- equality between them, which is impossible with Hs (too expressive) and with+-- Core (no notion of overloaded literals, and even plain 'Int' literals are+-- actually constructor apps). Also String literals are troublesome.++-- | Literals (simple and overloaded ones) for pattern match checking.+--+-- See Note [Undecidable Equality for PmAltCons]+data PmLit = PmLit+ { pm_lit_ty :: Type+ , pm_lit_val :: PmLitValue }++data PmLitValue+ = PmLitInt Integer+ | PmLitRat Rational+ | PmLitChar Char+ -- We won't actually see PmLitString in the oracle since we desugar strings to+ -- lists+ | PmLitString FastString+ | PmLitOverInt Int {- How often Negated? -} Integer+ | PmLitOverRat Int {- How often Negated? -} Rational+ | PmLitOverString FastString++-- | Undecidable semantic equality result.+-- See Note [Undecidable Equality for PmAltCons]+data PmEquality+ = Equal+ | Disjoint+ | PossiblyOverlap+ deriving (Eq, Show)++-- | When 'PmEquality' can be decided. @True <=> Equal@, @False <=> Disjoint@.+decEquality :: Bool -> PmEquality+decEquality True = Equal+decEquality False = Disjoint++-- | Undecidable equality for values represented by 'PmLit's.+-- See Note [Undecidable Equality for PmAltCons]+--+-- * @Just True@ ==> Surely equal+-- * @Just False@ ==> Surely different (non-overlapping, even!)+-- * @Nothing@ ==> Equality relation undecidable+eqPmLit :: PmLit -> PmLit -> PmEquality+eqPmLit (PmLit t1 v1) (PmLit t2 v2)+ -- no haddock | pprTrace "eqPmLit" (ppr t1 <+> ppr v1 $$ ppr t2 <+> ppr v2) False = undefined+ | not (t1 `eqType` t2) = Disjoint+ | otherwise = go v1 v2+ where+ go (PmLitInt i1) (PmLitInt i2) = decEquality (i1 == i2)+ go (PmLitRat r1) (PmLitRat r2) = decEquality (r1 == r2)+ go (PmLitChar c1) (PmLitChar c2) = decEquality (c1 == c2)+ go (PmLitString s1) (PmLitString s2) = decEquality (s1 == s2)+ go (PmLitOverInt n1 i1) (PmLitOverInt n2 i2)+ | n1 == n2 && i1 == i2 = Equal+ go (PmLitOverRat n1 r1) (PmLitOverRat n2 r2)+ | n1 == n2 && r1 == r2 = Equal+ go (PmLitOverString s1) (PmLitOverString s2)+ | s1 == s2 = Equal+ go _ _ = PossiblyOverlap++-- | Syntactic equality.+instance Eq PmLit where+ a == b = eqPmLit a b == Equal++-- | Type of a 'PmLit'+pmLitType :: PmLit -> Type+pmLitType (PmLit ty _) = ty++-- | Undecidable equality for values represented by 'ConLike's.+-- See Note [Undecidable Equality for PmAltCons].+-- 'PatSynCon's aren't enforced to be generative, so two syntactically different+-- 'PatSynCon's might match the exact same values. Without looking into and+-- reasoning about the pattern synonym's definition, we can't decide if their+-- sets of matched values is different.+--+-- * @Just True@ ==> Surely equal+-- * @Just False@ ==> Surely different (non-overlapping, even!)+-- * @Nothing@ ==> Equality relation undecidable+eqConLike :: ConLike -> ConLike -> PmEquality+eqConLike (RealDataCon dc1) (RealDataCon dc2) = decEquality (dc1 == dc2)+eqConLike (PatSynCon psc1) (PatSynCon psc2)+ | psc1 == psc2+ = Equal+eqConLike _ _ = PossiblyOverlap++-- | Represents the head of a match against a 'ConLike' or literal.+-- Really similar to 'GHC.Core.AltCon'.+data PmAltCon = PmAltConLike ConLike+ | PmAltLit PmLit++data PmAltConSet = PACS !ConLikeSet ![PmLit]++emptyPmAltConSet :: PmAltConSet+emptyPmAltConSet = PACS emptyUniqDSet []++isEmptyPmAltConSet :: PmAltConSet -> Bool+isEmptyPmAltConSet (PACS cls lits) = isEmptyUniqDSet cls && null lits++-- | Whether there is a 'PmAltCon' in the 'PmAltConSet' that compares 'Equal' to+-- the given 'PmAltCon' according to 'eqPmAltCon'.+elemPmAltConSet :: PmAltCon -> PmAltConSet -> Bool+elemPmAltConSet (PmAltConLike cl) (PACS cls _ ) = elementOfUniqDSet cl cls+elemPmAltConSet (PmAltLit lit) (PACS _ lits) = elem lit lits++extendPmAltConSet :: PmAltConSet -> PmAltCon -> PmAltConSet+extendPmAltConSet (PACS cls lits) (PmAltConLike cl)+ = PACS (addOneToUniqDSet cls cl) lits+extendPmAltConSet (PACS cls lits) (PmAltLit lit)+ = PACS cls (unionLists lits [lit])++pmAltConSetElems :: PmAltConSet -> [PmAltCon]+pmAltConSetElems (PACS cls lits)+ = map PmAltConLike (uniqDSetToList cls) ++ map PmAltLit lits++instance Outputable PmAltConSet where+ ppr = ppr . pmAltConSetElems++-- | We can't in general decide whether two 'PmAltCon's match the same set of+-- values. In addition to the reasons in 'eqPmLit' and 'eqConLike', a+-- 'PmAltConLike' might or might not represent the same value as a 'PmAltLit'.+-- See Note [Undecidable Equality for PmAltCons].+--+-- * @Just True@ ==> Surely equal+-- * @Just False@ ==> Surely different (non-overlapping, even!)+-- * @Nothing@ ==> Equality relation undecidable+--+-- Examples (omitting some constructor wrapping):+--+-- * @eqPmAltCon (LitInt 42) (LitInt 1) == Just False@: Lit equality is+-- decidable+-- * @eqPmAltCon (DataCon A) (DataCon B) == Just False@: DataCon equality is+-- decidable+-- * @eqPmAltCon (LitOverInt 42) (LitOverInt 1) == Nothing@: OverLit equality+-- is undecidable+-- * @eqPmAltCon (PatSyn PA) (PatSyn PB) == Nothing@: PatSyn equality is+-- undecidable+-- * @eqPmAltCon (DataCon I#) (LitInt 1) == Nothing@: DataCon to Lit+-- comparisons are undecidable without reasoning about the wrapped @Int#@+-- * @eqPmAltCon (LitOverInt 1) (LitOverInt 1) == Just True@: We assume+-- reflexivity for overloaded literals+-- * @eqPmAltCon (PatSyn PA) (PatSyn PA) == Just True@: We assume reflexivity+-- for Pattern Synonyms+eqPmAltCon :: PmAltCon -> PmAltCon -> PmEquality+eqPmAltCon (PmAltConLike cl1) (PmAltConLike cl2) = eqConLike cl1 cl2+eqPmAltCon (PmAltLit l1) (PmAltLit l2) = eqPmLit l1 l2+eqPmAltCon _ _ = PossiblyOverlap++-- | Syntactic equality.+instance Eq PmAltCon where+ a == b = eqPmAltCon a b == Equal++-- | Type of a 'PmAltCon'+pmAltConType :: PmAltCon -> [Type] -> Type+pmAltConType (PmAltLit lit) _arg_tys = ASSERT( null _arg_tys ) pmLitType lit+pmAltConType (PmAltConLike con) arg_tys = conLikeResTy con arg_tys++-- | Is a match on this constructor forcing the match variable?+-- True of data constructors, literals and pattern synonyms (#17357), but not of+-- newtypes.+-- See Note [Coverage checking Newtype matches] in "GHC.HsToCore.Pmc.Solver".+isPmAltConMatchStrict :: PmAltCon -> Bool+isPmAltConMatchStrict PmAltLit{} = True+isPmAltConMatchStrict (PmAltConLike PatSynCon{}) = True -- #17357+isPmAltConMatchStrict (PmAltConLike (RealDataCon dc)) = not (isNewDataCon dc)++pmAltConImplBangs :: PmAltCon -> [HsImplBang]+pmAltConImplBangs PmAltLit{} = []+pmAltConImplBangs (PmAltConLike con) = conLikeImplBangs con++{- Note [Undecidable Equality for PmAltCons]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Equality on overloaded literals is undecidable in the general case. Consider+the following example:++ instance Num Bool where+ ...+ fromInteger 0 = False -- C-like representation of booleans+ fromInteger _ = True++ f :: Bool -> ()+ f 1 = () -- Clause A+ f 2 = () -- Clause B++Clause B is redundant but to detect this, we must decide the constraint:+@fromInteger 2 ~ fromInteger 1@ which means that we+have to look through function @fromInteger@, whose implementation could+be anything. This poses difficulties for:++1. The expressive power of the check.+ We cannot expect a reasonable implementation of pattern matching to detect+ that @fromInteger 2 ~ fromInteger 1@ is True, unless we unfold function+ fromInteger. This puts termination at risk and is undecidable in the+ general case.++2. Error messages/Warnings.+ What should our message for @f@ above be? A reasonable approach would be+ to issue:++ Pattern matches are (potentially) redundant:+ f 2 = ... under the assumption that 1 == 2++ but seems to complex and confusing for the user.++We choose to equate only obviously equal overloaded literals, in all other cases+we signal undecidability by returning Nothing from 'eqPmAltCons'. We do+better for non-overloaded literals, because we know their fromInteger/fromString+implementation is actually injective, allowing us to simplify the constraint+@fromInteger 1 ~ fromInteger 2@ to @1 ~ 2@, which is trivially unsatisfiable.++The impact of this treatment of overloaded literals is the following:++ * Redundancy checking is rather conservative, since it cannot see that clause+ B above is redundant.++ * We have instant equality check for overloaded literals (we do not rely on+ the term oracle which is rather expensive, both in terms of performance and+ memory). This significantly improves the performance of functions `covered`+ `uncovered` and `divergent` in "GHC.HsToCore.Pmc" and effectively addresses+ #11161.++ * The warnings issued are simpler.++Similar reasoning applies to pattern synonyms: In contrast to data constructors,+which are generative, constraints like F a ~ G b for two different pattern+synonyms F and G aren't immediately unsatisfiable. We assume F a ~ F a, though.+-}++literalToPmLit :: Type -> Literal -> Maybe PmLit+literalToPmLit ty l = PmLit ty <$> go l+ where+ go (LitChar c) = Just (PmLitChar c)+ go (LitFloat r) = Just (PmLitRat r)+ go (LitDouble r) = Just (PmLitRat r)+ go (LitString s) = Just (PmLitString (mkFastStringByteString s))+ go (LitNumber _ i) = Just (PmLitInt i)+ go _ = Nothing++negatePmLit :: PmLit -> Maybe PmLit+negatePmLit (PmLit ty v) = PmLit ty <$> go v+ where+ go (PmLitInt i) = Just (PmLitInt (-i))+ go (PmLitRat r) = Just (PmLitRat (-r))+ go (PmLitOverInt n i) = Just (PmLitOverInt (n+1) i)+ go (PmLitOverRat n r) = Just (PmLitOverRat (n+1) r)+ go _ = Nothing++overloadPmLit :: Type -> PmLit -> Maybe PmLit+overloadPmLit ty (PmLit _ v) = PmLit ty <$> go v+ where+ go (PmLitInt i) = Just (PmLitOverInt 0 i)+ go (PmLitRat r) = Just (PmLitOverRat 0 r)+ go (PmLitString s)+ | ty `eqType` stringTy = Just v+ | otherwise = Just (PmLitOverString s)+ go _ = Nothing++pmLitAsStringLit :: PmLit -> Maybe FastString+pmLitAsStringLit (PmLit _ (PmLitString s)) = Just s+pmLitAsStringLit _ = Nothing++coreExprAsPmLit :: CoreExpr -> Maybe PmLit+-- coreExprAsPmLit e | pprTrace "coreExprAsPmLit" (ppr e) False = undefined+coreExprAsPmLit (Tick _t e) = coreExprAsPmLit e+coreExprAsPmLit (Lit l) = literalToPmLit (literalType l) l+coreExprAsPmLit e = case collectArgs e of+ (Var x, [Lit l])+ | Just dc <- isDataConWorkId_maybe x+ , dc `elem` [intDataCon, wordDataCon, charDataCon, floatDataCon, doubleDataCon]+ -> literalToPmLit (exprType e) l+ (Var x, [_ty, Lit n, Lit d])+ | Just dc <- isDataConWorkId_maybe x+ , dataConName dc == ratioDataConName+ -- HACK: just assume we have a literal double. This case only occurs for+ -- overloaded lits anyway, so we immediately override type information+ -> literalToPmLit (exprType e) (mkLitDouble (litValue n % litValue d))+ (Var x, args)+ -- See Note [Detecting overloaded literals with -XRebindableSyntax]+ | is_rebound_name x fromIntegerName+ , [Lit l] <- dropWhile (not . is_lit) args+ -> literalToPmLit (literalType l) l >>= overloadPmLit (exprType e)+ (Var x, args)+ -- See Note [Detecting overloaded literals with -XRebindableSyntax]+ | is_rebound_name x fromRationalName+ , [r] <- dropWhile (not . is_ratio) args+ -> coreExprAsPmLit r >>= overloadPmLit (exprType e)+ (Var x, args)+ | is_rebound_name x fromStringName+ -- See Note [Detecting overloaded literals with -XRebindableSyntax]+ , s:_ <- filter (isStringTy . exprType) $ filter isValArg args+ -- NB: Calls coreExprAsPmLit and then overloadPmLit, so that we return PmLitOverStrings+ -> coreExprAsPmLit s >>= overloadPmLit (exprType e)+ -- These last two cases handle proper String literals+ (Var x, [Type ty])+ | Just dc <- isDataConWorkId_maybe x+ , dc == nilDataCon+ , ty `eqType` charTy+ -> literalToPmLit stringTy (mkLitString "")+ (Var x, [Lit l])+ | idName x `elem` [unpackCStringName, unpackCStringUtf8Name]+ -> literalToPmLit stringTy l+ _ -> Nothing+ where+ is_lit Lit{} = True+ is_lit _ = False+ is_ratio (Type _) = False+ is_ratio r+ | Just (tc, _) <- splitTyConApp_maybe (exprType r)+ = tyConName tc == ratioTyConName+ | otherwise+ = False++ -- See Note [Detecting overloaded literals with -XRebindableSyntax]+ is_rebound_name :: Id -> Name -> Bool+ is_rebound_name x n = getOccFS (idName x) == getOccFS n++{- Note [Detecting overloaded literals with -XRebindableSyntax]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Normally, we'd find e.g. overloaded string literals by comparing the+application head of an expression to `fromStringName`. But that doesn't work+with -XRebindableSyntax: The `Name` of a user-provided `fromString` function is+different to `fromStringName`, which lives in a certain module, etc.++There really is no other way than to compare `OccName`s and guess which+argument is the actual literal string (we assume it's the first argument of+type `String`).++The same applies to other overloaded literals, such as overloaded rationals+(`fromRational`)and overloaded integer literals (`fromInteger`).+-}++instance Outputable PmLitValue where+ ppr (PmLitInt i) = ppr i+ ppr (PmLitRat r) = ppr (double (fromRat r)) -- good enough+ ppr (PmLitChar c) = pprHsChar c+ ppr (PmLitString s) = pprHsString s+ ppr (PmLitOverInt n i) = minuses n (ppr i)+ ppr (PmLitOverRat n r) = minuses n (ppr (double (fromRat r)))+ ppr (PmLitOverString s) = pprHsString s++-- Take care of negated literals+minuses :: Int -> SDoc -> SDoc+minuses n sdoc = iterate (\sdoc -> parens (char '-' <> sdoc)) sdoc !! n++instance Outputable PmLit where+ ppr (PmLit ty v) = ppr v <> suffix+ where+ -- Some ad-hoc hackery for displaying proper lit suffixes based on type+ tbl = [ (intPrimTy, primIntSuffix)+ , (int64PrimTy, primInt64Suffix)+ , (wordPrimTy, primWordSuffix)+ , (word64PrimTy, primWord64Suffix)+ , (charPrimTy, primCharSuffix)+ , (floatPrimTy, primFloatSuffix)+ , (doublePrimTy, primDoubleSuffix) ]+ suffix = fromMaybe empty (snd <$> find (eqType ty . fst) tbl)++instance Outputable PmAltCon where+ ppr (PmAltConLike cl) = ppr cl+ ppr (PmAltLit l) = ppr l++instance Outputable PmEquality where+ ppr = text . show
+ compiler/GHC/HsToCore/Pmc/Types.hs view
@@ -0,0 +1,241 @@+{-+Author: George Karachalias <george.karachalias@cs.kuleuven.be>+ Sebastian Graf <sgraf1337@gmail.com>+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveFunctor #-}++-- | Types used through-out pattern match checking. This module is mostly there+-- to be imported from "GHC.HsToCore.Types". The exposed API is that of+-- "GHC.HsToCore.Pmc".+--+-- These types model the paper+-- [Lower Your Guards: A Compositional Pattern-Match Coverage Checker"](https://dl.acm.org/doi/abs/10.1145/3408989).+module GHC.HsToCore.Pmc.Types (+ -- * LYG syntax++ -- ** Guard language+ SrcInfo(..), PmGrd(..), GrdVec(..),++ -- ** Guard tree language+ PmMatchGroup(..), PmMatch(..), PmGRHSs(..), PmGRHS(..), PmPatBind(..), PmEmptyCase(..),++ -- * Coverage Checking types+ RedSets (..), Precision (..), CheckResult (..),++ -- * Pre and post coverage checking synonyms+ Pre, Post,++ -- * Normalised refinement types+ module GHC.HsToCore.Pmc.Solver.Types++ ) where++#include "GhclibHsVersions.h"++import GHC.Prelude++import GHC.HsToCore.Pmc.Solver.Types++import GHC.Data.OrdList+import GHC.Types.Id+import GHC.Types.Var (EvVar)+import GHC.Types.SrcLoc+import GHC.Utils.Outputable+import GHC.Core.Type+import GHC.Core++import Data.List.NonEmpty ( NonEmpty(..) )+import qualified Data.List.NonEmpty as NE+import qualified Data.Semigroup as Semi++--+-- * Guard language+--++-- | A very simple language for pattern guards. Let bindings, bang patterns,+-- and matching variables against flat constructor patterns.+-- The LYG guard language.+data PmGrd+ = -- | @PmCon x K dicts args@ corresponds to a @K dicts args <- x@ guard.+ -- The @args@ are bound in this construct, the @x@ is just a use.+ -- For the arguments' meaning see 'GHC.Hs.Pat.ConPatOut'.+ PmCon {+ pm_id :: !Id,+ pm_con_con :: !PmAltCon,+ pm_con_tvs :: ![TyVar],+ pm_con_dicts :: ![EvVar],+ pm_con_args :: ![Id]+ }++ -- | @PmBang x@ corresponds to a @seq x True@ guard.+ -- If the extra 'SrcInfo' is present, the bang guard came from a source+ -- bang pattern, in which case we might want to report it as redundant.+ -- See Note [Dead bang patterns] in GHC.HsToCore.Pmc.Check.+ | PmBang {+ pm_id :: !Id,+ _pm_loc :: !(Maybe SrcInfo)+ }++ -- | @PmLet x expr@ corresponds to a @let x = expr@ guard. This actually+ -- /binds/ @x@.+ | PmLet {+ pm_id :: !Id,+ _pm_let_expr :: !CoreExpr+ }++-- | Should not be user-facing.+instance Outputable PmGrd where+ ppr (PmCon x alt _tvs _con_dicts con_args)+ = hsep [ppr alt, hsep (map ppr con_args), text "<-", ppr x]+ ppr (PmBang x _loc) = char '!' <> ppr x+ ppr (PmLet x expr) = hsep [text "let", ppr x, text "=", ppr expr]++--+-- * Guard tree language+--++-- | Means by which we identify a source construct for later pretty-printing in+-- a warning message. 'SDoc' for the equation to show, 'Located' for the+-- location.+newtype SrcInfo = SrcInfo (Located SDoc)++-- | A sequence of 'PmGrd's.+newtype GrdVec = GrdVec [PmGrd]++-- | A guard tree denoting 'MatchGroup'.+newtype PmMatchGroup p = PmMatchGroup (NonEmpty (PmMatch p))++-- | A guard tree denoting 'Match': A payload describing the pats and a bunch of+-- GRHS.+data PmMatch p = PmMatch { pm_pats :: !p, pm_grhss :: !(PmGRHSs p) }++-- | A guard tree denoting 'GRHSs': A bunch of 'PmLet' guards for local+-- bindings from the 'GRHSs's @where@ clauses and the actual list of 'GRHS'.+-- See Note [Long-distance information for HsLocalBinds] in+-- "GHC.HsToCore.Pmc.Desugar".+data PmGRHSs p = PmGRHSs { pgs_lcls :: !p, pgs_grhss :: !(NonEmpty (PmGRHS p))}++-- | A guard tree denoting 'GRHS': A payload describing the grds and a 'SrcInfo'+-- useful for printing out in warnings messages.+data PmGRHS p = PmGRHS { pg_grds :: !p, pg_rhs :: !SrcInfo }++-- | A guard tree denoting an -XEmptyCase.+newtype PmEmptyCase = PmEmptyCase { pe_var :: Id }++-- | A guard tree denoting a pattern binding.+newtype PmPatBind p =+ -- just reuse GrdGRHS and pretend its @SrcInfo@ is info on the /pattern/,+ -- rather than on the pattern bindings.+ PmPatBind (PmGRHS p)++instance Outputable SrcInfo where+ ppr (SrcInfo (L (RealSrcSpan rss _) _)) = ppr (srcSpanStartLine rss)+ ppr (SrcInfo (L s _)) = ppr s++-- | Format LYG guards as @| True <- x, let x = 42, !z@+instance Outputable GrdVec where+ ppr (GrdVec []) = empty+ ppr (GrdVec (g:gs)) = fsep (char '|' <+> ppr g : map ((comma <+>) . ppr) gs)++-- | Format a LYG sequence (e.g. 'Match'es of a 'MatchGroup' or 'GRHSs') as+-- @{ <first alt>; ...; <last alt> }@+pprLygSequence :: Outputable a => NonEmpty a -> SDoc+pprLygSequence (NE.toList -> as) =+ braces (space <> fsep (punctuate semi (map ppr as)) <> space)++instance Outputable p => Outputable (PmMatchGroup p) where+ ppr (PmMatchGroup matches) = pprLygSequence matches++instance Outputable p => Outputable (PmMatch p) where+ ppr (PmMatch { pm_pats = grds, pm_grhss = grhss }) =+ ppr grds <+> ppr grhss++instance Outputable p => Outputable (PmGRHSs p) where+ ppr (PmGRHSs { pgs_lcls = _lcls, pgs_grhss = grhss }) =+ ppr grhss++instance Outputable p => Outputable (PmGRHS p) where+ ppr (PmGRHS { pg_grds = grds, pg_rhs = rhs }) =+ ppr grds <+> text "->" <+> ppr rhs++instance Outputable p => Outputable (PmPatBind p) where+ ppr (PmPatBind PmGRHS { pg_grds = grds, pg_rhs = bind }) =+ ppr bind <+> ppr grds <+> text "=" <+> text "..."++instance Outputable PmEmptyCase where+ ppr (PmEmptyCase { pe_var = var }) =+ text "<empty case on " <> ppr var <> text ">"++data Precision = Approximate | Precise+ deriving (Eq, Show)++instance Outputable Precision where+ ppr = text . show++instance Semi.Semigroup Precision where+ Precise <> Precise = Precise+ _ <> _ = Approximate++instance Monoid Precision where+ mempty = Precise+ mappend = (Semi.<>)++-- | Redundancy sets, used to determine redundancy of RHSs and bang patterns+-- (later digested into a 'CIRB').+data RedSets+ = RedSets+ { rs_cov :: !Nablas+ -- ^ The /Covered/ set; the set of values reaching a particular program+ -- point.+ , rs_div :: !Nablas+ -- ^ The /Diverging/ set; empty if no match can lead to divergence.+ -- If it wasn't empty, we have to turn redundancy warnings into+ -- inaccessibility warnings for any subclauses.+ , rs_bangs :: !(OrdList (Nablas, SrcInfo))+ -- ^ If any of the 'Nablas' is empty, the corresponding 'SrcInfo' pin-points+ -- a bang pattern in source that is redundant. See Note [Dead bang patterns].+ }++instance Outputable RedSets where+ ppr RedSets { rs_cov = _cov, rs_div = _div, rs_bangs = _bangs }+ -- It's useful to change this definition for different verbosity levels in+ -- printf-debugging+ = empty++-- | Pattern-match coverage check result+data CheckResult a+ = CheckResult+ { cr_ret :: !a+ -- ^ A hole for redundancy info and covered sets.+ , cr_uncov :: !Nablas+ -- ^ The set of uncovered values falling out at the bottom.+ -- (for -Wincomplete-patterns, but also important state for the algorithm)+ , cr_approx :: !Precision+ -- ^ A flag saying whether we ran into the 'maxPmCheckModels' limit for the+ -- purpose of suggesting to crank it up in the warning message. Writer state.+ } deriving Functor++instance Outputable a => Outputable (CheckResult a) where+ ppr (CheckResult c unc pc)+ = text "CheckResult" <+> ppr_precision pc <+> braces (fsep+ [ field "ret" c <> comma+ , field "uncov" unc])+ where+ ppr_precision Precise = empty+ ppr_precision Approximate = text "(Approximate)"+ field name value = text name <+> equals <+> ppr value++--+-- * Pre and post coverage checking synonyms+--++-- | Used as tree payload pre-checking. The LYG guards to check.+type Pre = GrdVec++-- | Used as tree payload post-checking. The redundancy info we elaborated.+type Post = RedSets
+ compiler/GHC/HsToCore/Pmc/Utils.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE CPP, LambdaCase, TupleSections, PatternSynonyms, ViewPatterns,+ MultiWayIf, ScopedTypeVariables, MagicHash #-}++-- | Utility module for the pattern-match coverage checker.+module GHC.HsToCore.Pmc.Utils (++ tracePm, mkPmId,+ allPmCheckWarnings, overlapping, exhaustive, redundantBang,+ exhaustiveWarningFlag,+ isMatchContextPmChecked, needToRunPmCheck++ ) where++#include "GhclibHsVersions.h"++import GHC.Prelude++import GHC.Types.Basic (Origin(..), isGenerated)+import GHC.Driver.Session+import GHC.Hs+import GHC.Core.Type+import GHC.Data.FastString+import GHC.Data.IOEnv+import GHC.Types.Id+import GHC.Types.Name+import GHC.Types.Unique.Supply+import GHC.Types.SrcLoc+import GHC.Utils.Error+import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.HsToCore.Monad++tracePm :: String -> SDoc -> DsM ()+tracePm herald doc = do+ dflags <- getDynFlags+ printer <- mkPrintUnqualifiedDs+ liftIO $ dumpIfSet_dyn_printer printer dflags+ Opt_D_dump_ec_trace "" FormatText (text herald $$ (nest 2 doc))+{-# INLINE tracePm #-} -- see Note [INLINE conditional tracing utilities]++-- | Generate a fresh `Id` of a given type+mkPmId :: Type -> DsM Id+mkPmId ty = getUniqueM >>= \unique ->+ let occname = mkVarOccFS $ fsLit "pm"+ name = mkInternalName unique occname noSrcSpan+ in return (mkLocalIdOrCoVar name Many ty)++-- | All warning flags that need to run the pattern match checker.+allPmCheckWarnings :: [WarningFlag]+allPmCheckWarnings =+ [ Opt_WarnIncompletePatterns+ , Opt_WarnIncompleteUniPatterns+ , Opt_WarnIncompletePatternsRecUpd+ , Opt_WarnOverlappingPatterns+ ]++-- | Check whether the redundancy checker should run (redundancy only)+overlapping :: DynFlags -> HsMatchContext id -> Bool+-- See Note [Inaccessible warnings for record updates]+overlapping _ RecUpd = False+overlapping dflags _ = wopt Opt_WarnOverlappingPatterns dflags++-- | Check whether the exhaustiveness checker should run (exhaustiveness only)+exhaustive :: DynFlags -> HsMatchContext id -> Bool+exhaustive dflags = maybe False (`wopt` dflags) . exhaustiveWarningFlag++-- | Check whether unnecessary bangs should be warned about+redundantBang :: DynFlags -> Bool+redundantBang dflags = wopt Opt_WarnRedundantBangPatterns dflags++-- | Denotes whether an exhaustiveness check is supported, and if so,+-- via which 'WarningFlag' it's controlled.+-- Returns 'Nothing' if check is not supported.+exhaustiveWarningFlag :: HsMatchContext id -> Maybe WarningFlag+exhaustiveWarningFlag (FunRhs {}) = Just Opt_WarnIncompletePatterns+exhaustiveWarningFlag CaseAlt = Just Opt_WarnIncompletePatterns+exhaustiveWarningFlag IfAlt = Just Opt_WarnIncompletePatterns+exhaustiveWarningFlag LambdaExpr = Just Opt_WarnIncompleteUniPatterns+exhaustiveWarningFlag PatBindRhs = Just Opt_WarnIncompleteUniPatterns+exhaustiveWarningFlag PatBindGuards = Just Opt_WarnIncompletePatterns+exhaustiveWarningFlag ProcExpr = Just Opt_WarnIncompleteUniPatterns+exhaustiveWarningFlag RecUpd = Just Opt_WarnIncompletePatternsRecUpd+exhaustiveWarningFlag ThPatSplice = Nothing+exhaustiveWarningFlag PatSyn = Nothing+exhaustiveWarningFlag ThPatQuote = Nothing+-- Don't warn about incomplete patterns in list comprehensions, pattern guards+-- etc. They are often *supposed* to be incomplete+exhaustiveWarningFlag (StmtCtxt {}) = Nothing++-- | Check whether any part of pattern match checking is enabled for this+-- 'HsMatchContext' (does not matter whether it is the redundancy check or the+-- exhaustiveness check).+isMatchContextPmChecked :: DynFlags -> Origin -> HsMatchContext id -> Bool+isMatchContextPmChecked dflags origin kind+ | isGenerated origin+ = False+ | otherwise+ = overlapping dflags kind || exhaustive dflags kind++-- | Return True when any of the pattern match warnings ('allPmCheckWarnings')+-- are enabled, in which case we need to run the pattern match checker.+needToRunPmCheck :: DynFlags -> Origin -> Bool+needToRunPmCheck dflags origin+ | isGenerated origin+ = False+ | otherwise+ = notNull (filter (`wopt` dflags) allPmCheckWarnings)++{- Note [Inaccessible warnings for record updates]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#12957)+ data T a where+ T1 :: { x :: Int } -> T Bool+ T2 :: { x :: Int } -> T a+ T3 :: T a++ f :: T Char -> T a+ f r = r { x = 3 }++The desugarer will conservatively generate a case for T1 even though+it's impossible:+ f r = case r of+ T1 x -> T1 3 -- Inaccessible branch+ T2 x -> T2 3+ _ -> error "Missing"++We don't want to warn about the inaccessible branch because the programmer+didn't put it there! So we filter out the warning here.++The same can happen for long distance term constraints instead of type+constraints (#17783):++ data T = A { x :: Int } | B { x :: Int }+ f r@A{} = r { x = 3 }+ f _ = B 0++Here, the long distance info from the FunRhs match (@r ~ A x@) will make the+clause matching on @B@ of the desugaring to @case@ redundant. It's generated+code that we don't want to warn about.+-}
compiler/GHC/HsToCore/Quote.hs view
@@ -945,14 +945,19 @@ -> MetaM (Core (M TH.DerivClause)) repDerivClause (L _ (HsDerivingClause { deriv_clause_strategy = dcs- , deriv_clause_tys = L _ dct }))+ , deriv_clause_tys = dct })) = repDerivStrategy dcs $ \(MkC dcs') ->- do MkC dct' <- repListM typeTyConName (rep_deriv_ty . hsSigType) dct+ do MkC dct' <- rep_deriv_clause_tys dct rep2 derivClauseName [dcs',dct'] where- rep_deriv_ty :: LHsType GhcRn -> MetaM (Core (M TH.Type))- rep_deriv_ty ty = repLTy ty+ rep_deriv_clause_tys :: LDerivClauseTys GhcRn -> MetaM (Core [M TH.Type])+ rep_deriv_clause_tys (L _ dct) = case dct of+ DctSingle _ ty -> rep_deriv_tys [ty]+ DctMulti _ tys -> rep_deriv_tys tys + rep_deriv_tys :: [LHsSigType GhcRn] -> MetaM (Core [M TH.Type])+ rep_deriv_tys = repListM typeTyConName (repLTy . hsSigType)+ rep_meth_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn -> MetaM ([GenSymBind], [Core (M TH.Dec)]) -- Represent signatures and methods in class/instance declarations.@@ -1572,7 +1577,6 @@ repUnboundVar sname repE (XExpr (HsExpanded _ b)) = repE b repE e@(HsPragE _ HsPragSCC {} _) = notHandled "Cost centres" (ppr e)-repE e@(HsPragE _ HsPragTick {} _) = notHandled "Tick Pragma" (ppr e) repE e = notHandled "Expression form" (ppr e) -----------------------------------------------------------------------------
+ compiler/GHC/HsToCore/Types.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE TypeFamilies, UndecidableInstances #-}++-- | Various types used during desugaring.+module GHC.HsToCore.Types (+ DsM, DsLclEnv(..), DsGblEnv(..),+ DsMetaEnv, DsMetaVal(..), CompleteMatches+ ) where++import Data.IORef++import GHC.Types.CostCentre.State+import GHC.Types.Name.Env+import GHC.Types.SrcLoc+import GHC.Types.Var+import GHC.Hs (LForeignDecl, HsExpr, GhcTc)+import GHC.Tc.Types (TcRnIf, IfGblEnv, IfLclEnv, CompleteMatches)+import GHC.HsToCore.Pmc.Types (Nablas)+import GHC.Core (CoreExpr)+import GHC.Core.FamInstEnv+import GHC.Utils.Error+import GHC.Utils.Outputable as Outputable+import GHC.Unit.Module+import GHC.Driver.Hooks (DsForeignsHook)+import GHC.Data.OrdList (OrdList)+import GHC.Driver.Types (ForeignStubs)++{-+************************************************************************+* *+ Desugarer monad+* *+************************************************************************++Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around+a @UniqueSupply@ and some annotations, which+presumably include source-file location information:+-}++-- | Global read-only context and state of the desugarer.+-- The statefulness is implemented through 'IORef's.+data DsGblEnv+ = DsGblEnv+ { ds_mod :: Module -- For SCC profiling+ , ds_fam_inst_env :: FamInstEnv -- Like tcg_fam_inst_env+ , ds_unqual :: PrintUnqualified+ , ds_msgs :: IORef Messages -- Warning messages+ , ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global,+ -- possibly-imported things+ , ds_complete_matches :: CompleteMatches+ -- Additional complete pattern matches+ , ds_cc_st :: IORef CostCentreState+ -- Tracking indices for cost centre annotations+ }++instance ContainsModule DsGblEnv where+ extractModule = ds_mod++-- | Local state of the desugarer, extended as we lexically descend+data DsLclEnv+ = DsLclEnv+ { dsl_meta :: DsMetaEnv -- ^ Template Haskell bindings+ , dsl_loc :: RealSrcSpan -- ^ To put in pattern-matching error msgs+ , dsl_nablas :: Nablas+ -- ^ See Note [Note [Long-distance information] in "GHC.HsToCore.Pmc".+ -- The set of reaching values Nablas is augmented as we walk inwards, refined+ -- through each pattern match in turn+ }++-- Inside [| |] brackets, the desugarer looks+-- up variables in the DsMetaEnv+type DsMetaEnv = NameEnv DsMetaVal++data DsMetaVal+ = DsBound Id -- Bound by a pattern inside the [| |].+ -- Will be dynamically alpha renamed.+ -- The Id has type THSyntax.Var++ | DsSplice (HsExpr GhcTc) -- These bindings are introduced by+ -- the PendingSplices on a HsBracketOut++-- | Desugaring monad. See also 'TcM'.+type DsM = TcRnIf DsGblEnv DsLclEnv++-- See Note [The Decoupling Abstract Data Hack]+type instance DsForeignsHook = [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList (Id, CoreExpr))
compiler/GHC/HsToCore/Usage.hs view
@@ -20,6 +20,7 @@ import GHC.Types.Name import GHC.Types.Name.Set import GHC.Unit+import GHC.Unit.State import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Types.Unique.Set
compiler/GHC/Iface/Ext/Ast.hs view
@@ -19,7 +19,7 @@ {-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -module GHC.Iface.Ext.Ast ( mkHieFile, mkHieFileWithSource, getCompressedAsts) where+module GHC.Iface.Ext.Ast ( mkHieFile, mkHieFileWithSource, getCompressedAsts, enrichHie) where import GHC.Utils.Outputable(ppr) @@ -42,7 +42,7 @@ import GHC.Unit.Module ( ModuleName, ml_hs_file ) import GHC.Utils.Monad ( concatMapM, liftIO ) import GHC.Types.Id ( isDataConId_maybe )-import GHC.Types.Name ( Name, nameSrcSpan, setNameLoc, nameUnique )+import GHC.Types.Name ( Name, nameSrcSpan, nameUnique ) import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv ) import GHC.Types.SrcLoc import GHC.Tc.Utils.Zonk ( hsLitType, hsPatType )@@ -52,7 +52,7 @@ import GHC.Builtin.Types ( mkListTy, mkSumTy ) import GHC.Tc.Types import GHC.Tc.Types.Evidence-import GHC.Types.Var ( Id, Var, EvId, setVarName, varName, varType, varUnique )+import GHC.Types.Var ( Id, Var, EvId, varName, setVarName, varType, varUnique ) import GHC.Types.Var.Env import GHC.Builtin.Uniques import GHC.Iface.Make ( mkIfaceExports )@@ -342,7 +342,7 @@ , exps ] - modulify file xs' = do+ modulify (HiePath file) xs' = do top_ev_asts <- toHie $ EvBindContext ModuleScope Nothing@@ -363,12 +363,12 @@ case mergeSortAsts $ moduleNode : xs of [x] -> return x- xs -> panicDoc "enrichHie: mergeSortAsts returned more than one result" (ppr $ map nodeSpan xs)+ xs -> panicDoc "enrichHie: mergeSortAsts retur:ed more than one result" (ppr $ map nodeSpan xs) asts' <- sequence $ M.mapWithKey modulify $ M.fromListWith (++)- $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts+ $ map (\x -> (HiePath (srcSpanFile (nodeSpan x)),[x])) flat_asts let asts = HieASTs $ resolveTyVarScopes asts' return asts@@ -785,6 +785,7 @@ , Data (HsTupArg (GhcPass p)) , Data (IPBind (GhcPass p)) , ToHie (Context (Located (IdGhcP p)))+ , ToHie (Context (Located (XUnboundVar (GhcPass p)))) , ToHie (RFContext (Located (AmbiguousFieldOcc (GhcPass p)))) , ToHie (RFContext (Located (FieldOcc (GhcPass p)))) , ToHie (TScoped (LHsWcType (GhcPass (NoGhcTcPass p))))@@ -799,6 +800,9 @@ instance HiePass 'Typechecked where hiePass = HieTc +instance ToHie (Context (Located NoExtField)) where+ toHie _ = pure []+ instance HiePass p => ToHie (BindContext (Located (HsBind (GhcPass p)))) where toHie (BC context scope b@(L span bind)) = concatM $ getTypeNode b : case bind of@@ -1042,8 +1046,8 @@ [ toHie $ C Use (L mspan var) -- Patch up var location since typechecker removes it ]- HsUnboundVar _ _ ->- []+ HsUnboundVar var _ ->+ [ toHie $ C Use (L mspan var) ] HsConLikeOut _ con -> [ toHie $ C Use $ L mspan $ conLikeName con ]@@ -1272,26 +1276,22 @@ , toHie expr ] -removeDefSrcSpan :: Name -> Name-removeDefSrcSpan n = setNameLoc n noSrcSpan- instance ToHie (RFContext (Located (FieldOcc GhcRn))) where toHie (RFC c rhs (L nspan f)) = concatM $ case f of FieldOcc name _ ->- [ toHie $ C (RecField c rhs) (L nspan $ removeDefSrcSpan name)+ [ toHie $ C (RecField c rhs) (L nspan name) ] instance ToHie (RFContext (Located (FieldOcc GhcTc))) where toHie (RFC c rhs (L nspan f)) = concatM $ case f of FieldOcc var _ ->- let var' = setVarName var (removeDefSrcSpan $ varName var)- in [ toHie $ C (RecField c rhs) (L nspan var')- ]+ [ toHie $ C (RecField c rhs) (L nspan var)+ ] instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of Unambiguous name _ ->- [ toHie $ C (RecField c rhs) $ L nspan $ removeDefSrcSpan name+ [ toHie $ C (RecField c rhs) $ L nspan name ] Ambiguous _name _ -> [ ]@@ -1299,13 +1299,11 @@ instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of Unambiguous var _ ->- let var' = setVarName var (removeDefSrcSpan $ varName var)- in [ toHie $ C (RecField c rhs) (L nspan var')- ]+ [ toHie $ C (RecField c rhs) (L nspan var)+ ] Ambiguous var _ ->- let var' = setVarName var (removeDefSrcSpan $ varName var)- in [ toHie $ C (RecField c rhs) (L nspan var')- ]+ [ toHie $ C (RecField c rhs) (L nspan var)+ ] instance HiePass p => ToHie (RScoped (ApplicativeArg (GhcPass p))) where toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM@@ -1507,11 +1505,15 @@ instance ToHie (Located (HsDerivingClause GhcRn)) where toHie (L span cl) = concatM $ makeNode cl span : case cl of- HsDerivingClause _ strat (L ispan tys) ->+ HsDerivingClause _ strat dct -> [ toHie strat- , locOnly ispan- , toHie $ map (TS (ResolvedScopes [])) tys+ , toHie dct ]++instance ToHie (Located (DerivClauseTys GhcRn)) where+ toHie (L span dct) = concatM $ makeNode dct span : case dct of+ DctSingle _ ty -> [ toHie $ TS (ResolvedScopes[]) ty ]+ DctMulti _ tys -> [ toHie $ map (TS (ResolvedScopes [])) tys ] instance ToHie (Located (DerivStrategy GhcRn)) where toHie (L span strat) = concatM $ makeNode strat span : case strat of
compiler/GHC/Iface/Ext/Debug.hs view
@@ -11,7 +11,6 @@ import GHC.Types.SrcLoc import GHC.Unit.Module-import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Iface.Ext.Types@@ -28,7 +27,7 @@ diffFile :: Diff HieFile diffFile = diffAsts eqDiff `on` (getAsts . hie_asts) -diffAsts :: (Outputable a, Eq a, Ord a) => Diff a -> Diff (M.Map FastString (HieAST a))+diffAsts :: (Outputable a, Eq a, Ord a) => Diff a -> Diff (M.Map HiePath (HieAST a)) diffAsts f = diffList (diffAst f) `on` M.elems diffAst :: (Outputable a, Eq a,Ord a) => Diff a -> Diff (HieAST a)@@ -106,7 +105,7 @@ -- | Look for any identifiers which occur outside of their supposed scopes. -- Returns a list of error messages.-validateScopes :: Module -> M.Map FastString (HieAST a) -> [SDoc]+validateScopes :: Module -> M.Map HiePath (HieAST a) -> [SDoc] validateScopes mod asts = validScopes ++ validEvs where refMap = generateReferencesMap asts
compiler/GHC/Iface/Ext/Types.hs view
@@ -10,13 +10,15 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+ module GHC.Iface.Ext.Types where import GHC.Prelude import GHC.Settings.Config import GHC.Utils.Binary-import GHC.Data.FastString ( FastString )+import GHC.Data.FastString import GHC.Builtin.Utils import GHC.Iface.Type import GHC.Unit.Module ( ModuleName, Module )@@ -211,9 +213,18 @@ put_ bh (HieArgs xs) = put_ bh xs get bh = HieArgs <$> get bh --- | Mapping from filepaths (represented using 'FastString') to the--- corresponding AST-newtype HieASTs a = HieASTs { getAsts :: (M.Map FastString (HieAST a)) }++-- A HiePath is just a lexical FastString. We use a lexical FastString to avoid+-- non-determinism when printing or storing HieASTs which are sorted by their+-- HiePath.+type HiePath = LexicalFastString++{-# COMPLETE HiePath #-}+pattern HiePath :: FastString -> HiePath+pattern HiePath fs = LexicalFastString fs++-- | Mapping from filepaths to the corresponding AST+newtype HieASTs a = HieASTs { getAsts :: M.Map HiePath (HieAST a) } deriving (Functor, Foldable, Traversable) instance Binary (HieASTs TypeIndex) where@@ -285,13 +296,35 @@ put_ bh b = putByte bh (fromIntegral (fromEnum b)) get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x)) +-- | A node annotation+data NodeAnnotation = NodeAnnotation+ { nodeAnnotConstr :: !FastString -- ^ name of the AST node constructor+ , nodeAnnotType :: !FastString -- ^ name of the AST node Type+ }+ deriving (Eq)++instance Ord NodeAnnotation where+ compare (NodeAnnotation c0 t0) (NodeAnnotation c1 t1)+ = mconcat [uniqCompareFS c0 c1, uniqCompareFS t0 t1]++instance Outputable NodeAnnotation where+ ppr (NodeAnnotation c t) = ppr (c,t)++instance Binary NodeAnnotation where+ put_ bh (NodeAnnotation c t) = do+ put_ bh c+ put_ bh t+ get bh = NodeAnnotation+ <$> get bh+ <*> get bh+ -- | The information stored in one AST node. -- -- The type parameter exists to provide flexibility in representation of types -- (see Note [Efficient serialization of redundant type info]). data NodeInfo a = NodeInfo- { nodeAnnotations :: S.Set (FastString,FastString)- -- ^ (name of the AST node constructor, name of the AST node Type)+ { nodeAnnotations :: S.Set NodeAnnotation+ -- ^ Annotations , nodeType :: [a] -- ^ The Haskell types of this node, if any.
compiler/GHC/Iface/Ext/Utils.hs view
@@ -85,7 +85,7 @@ selectPoint :: HieFile -> (Int,Int) -> Maybe (HieAST Int) selectPoint hf (sl,sc) = getFirst $- flip foldMap (M.toList (getAsts $ hie_asts hf)) $ \(fs,ast) -> First $+ flip foldMap (M.toList (getAsts $ hie_asts hf)) $ \(HiePath fs,ast) -> First $ case selectSmallestContaining (sp fs) ast of Nothing -> Nothing Just ast' -> Just ast'@@ -248,12 +248,12 @@ return $ HCastTy i go (CoercionTy _) = return HCoercionTy -resolveTyVarScopes :: M.Map FastString (HieAST a) -> M.Map FastString (HieAST a)+resolveTyVarScopes :: M.Map HiePath (HieAST a) -> M.Map HiePath (HieAST a) resolveTyVarScopes asts = M.map go asts where go ast = resolveTyVarScopeLocal ast asts -resolveTyVarScopeLocal :: HieAST a -> M.Map FastString (HieAST a) -> HieAST a+resolveTyVarScopeLocal :: HieAST a -> M.Map HiePath (HieAST a) -> HieAST a resolveTyVarScopeLocal ast asts = go ast where resolveNameScope dets = dets{identInfo =@@ -278,12 +278,12 @@ where idents = M.map resolveNameScope $ nodeIdentifiers i -getNameBinding :: Name -> M.Map FastString (HieAST a) -> Maybe Span+getNameBinding :: Name -> M.Map HiePath (HieAST a) -> Maybe Span getNameBinding n asts = do (_,msp) <- getNameScopeAndBinding n asts msp -getNameScope :: Name -> M.Map FastString (HieAST a) -> Maybe [Scope]+getNameScope :: Name -> M.Map HiePath (HieAST a) -> Maybe [Scope] getNameScope n asts = do (scopes,_) <- getNameScopeAndBinding n asts return scopes@@ -291,10 +291,10 @@ getNameBindingInClass :: Name -> Span- -> M.Map FastString (HieAST a)+ -> M.Map HiePath (HieAST a) -> Maybe Span getNameBindingInClass n sp asts = do- ast <- M.lookup (srcSpanFile sp) asts+ ast <- M.lookup (HiePath (srcSpanFile sp)) asts getFirst $ foldMap First $ do child <- flattenAst ast dets <- maybeToList@@ -304,11 +304,11 @@ getNameScopeAndBinding :: Name- -> M.Map FastString (HieAST a)+ -> M.Map HiePath (HieAST a) -> Maybe ([Scope], Maybe Span) getNameScopeAndBinding n asts = case nameSrcSpan n of RealSrcSpan sp _ -> do -- @Maybe- ast <- M.lookup (srcSpanFile sp) asts+ ast <- M.lookup (HiePath (srcSpanFile sp)) asts defNode <- selectLargestContainedBy sp ast getFirst $ foldMap First $ do -- @[] node <- flattenAst defNode@@ -369,9 +369,9 @@ | sp `containsSpan` nodeSpan node = Nothing | otherwise = Nothing -definedInAsts :: M.Map FastString (HieAST a) -> Name -> Bool+definedInAsts :: M.Map HiePath (HieAST a) -> Name -> Bool definedInAsts asts n = case nameSrcSpan n of- RealSrcSpan sp _ -> srcSpanFile sp `elem` M.keys asts+ RealSrcSpan sp _ -> M.member (HiePath (srcSpanFile sp)) asts _ -> False getEvidenceBindDeps :: ContextInfo -> [Name]@@ -515,7 +515,7 @@ mergePairs (xs:ys:xss) = mergeAsts xs ys : mergePairs xss simpleNodeInfo :: FastString -> FastString -> NodeInfo a-simpleNodeInfo cons typ = NodeInfo (S.singleton (cons, typ)) [] M.empty+simpleNodeInfo cons typ = NodeInfo (S.singleton (NodeAnnotation cons typ)) [] M.empty locOnly :: Monad m => SrcSpan -> ReaderT NodeOrigin m [HieAST a] locOnly (RealSrcSpan span _) = do@@ -568,7 +568,7 @@ org <- ask pure $ case spn of RealSrcSpan span _ ->- [Node (mkSourcedNodeInfo org $ NodeInfo (S.singleton (cons,typ)) [etyp] M.empty) span []]+ [Node (mkSourcedNodeInfo org $ NodeInfo (S.singleton (NodeAnnotation cons typ)) [etyp] M.empty) span []] _ -> [] where cons = mkFastString . show . toConstr $ x
compiler/GHC/Iface/Load.hs view
@@ -38,7 +38,7 @@ import {-# SOURCE #-} GHC.IfaceToCore ( tcIfaceDecl, tcIfaceRules, tcIfaceInst, tcIfaceFamInst- , tcIfaceAnnotations, tcIfaceCompleteSigs )+ , tcIfaceAnnotations, tcIfaceCompleteMatches ) import GHC.Driver.Session import GHC.Driver.Backend@@ -479,7 +479,7 @@ ; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) ; new_eps_rules <- tcIfaceRules ignore_prags (mi_rules iface) ; new_eps_anns <- tcIfaceAnnotations (mi_anns iface)- ; new_eps_complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)+ ; new_eps_complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface) ; let { final_iface = iface { mi_decls = panic "No mi_decls in PIT",@@ -509,9 +509,7 @@ eps_rule_base = extendRuleBaseList (eps_rule_base eps) new_eps_rules, eps_complete_matches- = extendCompleteMatchMap- (eps_complete_matches eps)- new_eps_complete_sigs,+ = eps_complete_matches eps ++ new_eps_complete_matches, eps_inst_env = extendInstEnvList (eps_inst_env eps) new_eps_insts, eps_fam_inst_env = extendFamInstEnvList (eps_fam_inst_env eps)@@ -1037,9 +1035,8 @@ eps_fam_inst_env = emptyFamInstEnv, eps_rule_base = mkRuleBase builtinRules', -- Initialise the EPS rule pool with the built-in rules- eps_mod_fam_inst_env- = emptyModuleEnv,- eps_complete_matches = emptyUFM,+ eps_mod_fam_inst_env = emptyModuleEnv,+ eps_complete_matches = [], eps_ann_env = emptyAnnEnv, eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0 , n_insts_in = 0, n_insts_out = 0@@ -1181,7 +1178,7 @@ , ppr (mi_warns iface) , pprTrustInfo (mi_trust iface) , pprTrustPkg (mi_trust_pkg iface)- , vcat (map ppr (mi_complete_sigs iface))+ , vcat (map ppr (mi_complete_matches iface)) , text "module header:" $$ nest 2 (ppr (mi_doc_hdr iface)) , text "declaration docs:" $$ nest 2 (ppr (mi_decl_docs iface)) , text "arg docs:" $$ nest 2 (ppr (mi_arg_docs iface))
compiler/GHC/Iface/Make.hs view
@@ -57,6 +57,7 @@ import GHC.Types.Name.Reader import GHC.Types.Name.Env import GHC.Types.Name.Set+import GHC.Types.Unique.DSet import GHC.Unit import GHC.Utils.Error import GHC.Utils.Outputable@@ -220,7 +221,7 @@ md_anns = anns, md_types = type_env, md_exports = exports,- md_complete_sigs = complete_sigs }+ md_complete_matches = complete_matches } -- NB: notice that mkIface does not look at the bindings -- only at the TypeEnv. The previous Tidy phase has -- put exactly the info into the TypeEnv that we want@@ -256,7 +257,7 @@ iface_fam_insts = map famInstToIfaceFamInst fam_insts trust_info = setSafeMode safe_mode annotations = map mkIfaceAnnotation anns- icomplete_sigs = map mkIfaceCompleteSig complete_sigs+ icomplete_matches = map mkIfaceCompleteMatch complete_matches ModIface { mi_module = this_mod,@@ -285,14 +286,14 @@ mi_hpc = isHpcUsed hpc_info, mi_trust = trust_info, mi_trust_pkg = pkg_trust_req,- mi_complete_sigs = icomplete_sigs,+ mi_complete_matches = icomplete_matches, mi_doc_hdr = doc_hdr, mi_decl_docs = decl_docs, mi_arg_docs = arg_docs, mi_final_exts = (), mi_ext_fields = emptyExtensibleFields } where- cmp_rule = comparing ifRuleName+ cmp_rule = lexicalCompareFS `on` ifRuleName -- Compare these lexicographically by OccName, *not* by unique, -- because the latter is not stable across compilations: cmp_inst = comparing (nameOccName . ifDFun)@@ -322,8 +323,9 @@ ************************************************************************ -} -mkIfaceCompleteSig :: CompleteMatch -> IfaceCompleteMatch-mkIfaceCompleteSig (CompleteMatch cls tc) = IfaceCompleteMatch cls tc+mkIfaceCompleteMatch :: CompleteMatch -> IfaceCompleteMatch+mkIfaceCompleteMatch cls =+ IfaceCompleteMatch (map conLikeName (uniqDSetToList cls)) {-
compiler/GHC/Iface/Recomp.hs view
@@ -37,8 +37,9 @@ import GHC.Types.SrcLoc import GHC.Utils.Outputable as Outputable import GHC.Types.Unique-import GHC.Utils.Misc hiding ( eqListBy )+import GHC.Utils.Misc as Utils hiding ( eqListBy ) import GHC.Data.Maybe+import GHC.Data.FastString import GHC.Utils.Binary import GHC.Utils.Fingerprint import GHC.Utils.Exception@@ -1081,11 +1082,11 @@ sortDependencies :: Dependencies -> Dependencies sortDependencies d- = Deps { dep_mods = sortBy (compare `on` (moduleNameFS . gwib_mod)) (dep_mods d),+ = Deps { dep_mods = sortBy (lexicalCompareFS `on` (moduleNameFS . gwib_mod)) (dep_mods d), dep_pkgs = sortBy (compare `on` fst) (dep_pkgs d), dep_orphs = sortBy stableModuleCmp (dep_orphs d), dep_finsts = sortBy stableModuleCmp (dep_finsts d),- dep_plgins = sortBy (compare `on` moduleNameFS) (dep_plgins d) }+ dep_plgins = sortBy (lexicalCompareFS `on` moduleNameFS) (dep_plgins d) } {- ************************************************************************@@ -1338,7 +1339,7 @@ where go (non_orphs, orphs) d | NotOrphan occ <- get_key d- = (extendOccEnv_Acc (:) singleton non_orphs occ d, orphs)+ = (extendOccEnv_Acc (:) Utils.singleton non_orphs occ d, orphs) | otherwise = (non_orphs, d:orphs) -- -----------------------------------------------------------------------------
compiler/GHC/Iface/Rename.hs view
@@ -23,6 +23,7 @@ import GHC.Utils.Outputable import GHC.Driver.Types import GHC.Unit+import GHC.Unit.State import GHC.Types.Unique.FM import GHC.Types.Avail import GHC.Iface.Syntax
compiler/GHC/Iface/Tidy.hs view
@@ -22,6 +22,7 @@ import GHC.Driver.Ppr import GHC.Core import GHC.Core.Unfold+import GHC.Core.Unfold.Make import GHC.Core.FVs import GHC.Core.Tidy import GHC.Core.Opt.Monad@@ -142,7 +143,7 @@ tcg_patsyns = pat_syns, tcg_insts = insts, tcg_fam_insts = fam_insts,- tcg_complete_matches = complete_sigs,+ tcg_complete_matches = complete_matches, tcg_mod = this_mod } = -- This timing isn't terribly useful since the result isn't forced, but@@ -150,13 +151,13 @@ Err.withTiming dflags (text "CoreTidy"<+>brackets (ppr this_mod)) (const ()) $- return (ModDetails { md_types = type_env'- , md_insts = insts'- , md_fam_insts = fam_insts- , md_rules = []- , md_anns = []- , md_exports = exports- , md_complete_sigs = complete_sigs+ return (ModDetails { md_types = type_env'+ , md_insts = insts'+ , md_fam_insts = fam_insts+ , md_rules = []+ , md_anns = []+ , md_exports = exports+ , md_complete_matches = complete_matches }) where dflags = hsc_dflags hsc_env@@ -345,22 +346,22 @@ -} tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)-tidyProgram hsc_env (ModGuts { mg_module = mod- , mg_exports = exports- , mg_rdr_env = rdr_env- , mg_tcs = tcs- , mg_insts = cls_insts- , mg_fam_insts = fam_insts- , mg_binds = binds- , mg_patsyns = patsyns- , mg_rules = imp_rules- , mg_anns = anns- , mg_complete_sigs = complete_sigs- , mg_deps = deps- , mg_foreign = foreign_stubs- , mg_foreign_files = foreign_files- , mg_hpc_info = hpc_info- , mg_modBreaks = modBreaks+tidyProgram hsc_env (ModGuts { mg_module = mod+ , mg_exports = exports+ , mg_rdr_env = rdr_env+ , mg_tcs = tcs+ , mg_insts = cls_insts+ , mg_fam_insts = fam_insts+ , mg_binds = binds+ , mg_patsyns = patsyns+ , mg_rules = imp_rules+ , mg_anns = anns+ , mg_complete_matches = complete_matches+ , mg_deps = deps+ , mg_foreign = foreign_stubs+ , mg_foreign_files = foreign_files+ , mg_hpc_info = hpc_info+ , mg_modBreaks = modBreaks }) = Err.withTiming dflags@@ -381,13 +382,15 @@ ; let { (trimmed_binds, trimmed_rules) = findExternalRules omit_prags binds imp_rules unfold_env } + ; let uf_opts = unfoldingOpts dflags ; (tidy_env, tidy_binds)- <- tidyTopBinds hsc_env unfold_env tidy_occ_env trimmed_binds+ <- tidyTopBinds uf_opts unfold_env tidy_occ_env trimmed_binds -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable. ; (spt_entries, tidy_binds') <- sptCreateStaticBinds hsc_env mod tidy_binds- ; let { spt_init_code = sptModuleInitCode mod spt_entries+ ; let { platform = targetPlatform (hsc_dflags hsc_env)+ ; spt_init_code = sptModuleInitCode platform mod spt_entries ; add_spt_init_code = case backend dflags of -- If we are compiling for the interpreter we will insert@@ -465,13 +468,13 @@ cg_modBreaks = modBreaks, cg_spt_entries = spt_entries }, - ModDetails { md_types = tidy_type_env,- md_rules = tidy_rules,- md_insts = tidy_cls_insts,- md_fam_insts = fam_insts,- md_exports = exports,- md_anns = anns, -- are already tidy- md_complete_sigs = complete_sigs+ ModDetails { md_types = tidy_type_env,+ md_rules = tidy_rules,+ md_insts = tidy_cls_insts,+ md_fam_insts = fam_insts,+ md_exports = exports,+ md_anns = anns, -- are already tidy+ md_complete_matches = complete_matches }) } where@@ -1108,43 +1111,41 @@ -- -- * subst_env: A Var->Var mapping that substitutes the new Var for the old -tidyTopBinds :: HscEnv+tidyTopBinds :: UnfoldingOpts -> UnfoldEnv -> TidyOccEnv -> CoreProgram -> IO (TidyEnv, CoreProgram) -tidyTopBinds hsc_env unfold_env init_occ_env binds+tidyTopBinds uf_opts unfold_env init_occ_env binds = do let result = tidy init_env binds seqBinds (snd result) `seq` return result -- This seqBinds avoids a spike in space usage (see #13564) where- dflags = hsc_dflags hsc_env- init_env = (init_occ_env, emptyVarEnv) - tidy = mapAccumL (tidyTopBind dflags unfold_env)+ tidy = mapAccumL (tidyTopBind uf_opts unfold_env) -------------------------tidyTopBind :: DynFlags+tidyTopBind :: UnfoldingOpts -> UnfoldEnv -> TidyEnv -> CoreBind -> (TidyEnv, CoreBind) -tidyTopBind dflags unfold_env+tidyTopBind uf_opts unfold_env (occ_env,subst1) (NonRec bndr rhs) = (tidy_env2, NonRec bndr' rhs') where Just (name',show_unfold) = lookupVarEnv unfold_env bndr- (bndr', rhs') = tidyTopPair dflags show_unfold tidy_env2 name' (bndr, rhs)+ (bndr', rhs') = tidyTopPair uf_opts show_unfold tidy_env2 name' (bndr, rhs) subst2 = extendVarEnv subst1 bndr bndr' tidy_env2 = (occ_env, subst2) -tidyTopBind dflags unfold_env (occ_env, subst1) (Rec prs)+tidyTopBind uf_opts unfold_env (occ_env, subst1) (Rec prs) = (tidy_env2, Rec prs') where- prs' = [ tidyTopPair dflags show_unfold tidy_env2 name' (id,rhs)+ prs' = [ tidyTopPair uf_opts show_unfold tidy_env2 name' (id,rhs) | (id,rhs) <- prs, let (name',show_unfold) = expectJust "tidyTopBind" $ lookupVarEnv unfold_env id@@ -1156,7 +1157,7 @@ bndrs = map fst prs ------------------------------------------------------------tidyTopPair :: DynFlags+tidyTopPair :: UnfoldingOpts -> Bool -- show unfolding -> TidyEnv -- The TidyEnv is used to tidy the IdInfo -- It is knot-tied: don't look at it!@@ -1169,14 +1170,14 @@ -- group, a variable late in the group might be mentioned -- in the IdInfo of one early in the group -tidyTopPair dflags show_unfold rhs_tidy_env name' (bndr, rhs)+tidyTopPair uf_opts show_unfold rhs_tidy_env name' (bndr, rhs) = (bndr1, rhs1) where bndr1 = mkGlobalId details name' ty' idinfo' details = idDetails bndr -- Preserve the IdDetails ty' = tidyTopType (idType bndr) rhs1 = tidyExpr rhs_tidy_env rhs- idinfo' = tidyTopIdInfo dflags rhs_tidy_env name' rhs rhs1 (idInfo bndr)+ idinfo' = tidyTopIdInfo uf_opts rhs_tidy_env name' rhs rhs1 (idInfo bndr) show_unfold -- tidyTopIdInfo creates the final IdInfo for top-level@@ -1186,9 +1187,9 @@ -- Indeed, CorePrep must eta expand where necessary to make -- the manifest arity equal to the claimed arity. ---tidyTopIdInfo :: DynFlags -> TidyEnv -> Name -> CoreExpr -> CoreExpr+tidyTopIdInfo :: UnfoldingOpts -> TidyEnv -> Name -> CoreExpr -> CoreExpr -> IdInfo -> Bool -> IdInfo-tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold+tidyTopIdInfo uf_opts rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold | not is_external -- For internal Ids (not externally visible) = vanillaIdInfo -- we only need enough info for code generation -- Arity and strictness info are enough;@@ -1245,7 +1246,7 @@ | otherwise = minimal_unfold_info minimal_unfold_info = zapUnfolding unf_info- unf_from_rhs = mkFinalUnfolding dflags InlineRhs final_sig tidy_rhs+ unf_from_rhs = mkFinalUnfolding uf_opts InlineRhs final_sig tidy_rhs -- NB: do *not* expose the worker if show_unfold is off, -- because that means this thing is a loop breaker or -- marked NOINLINE or something like that
compiler/GHC/Iface/Tidy/StaticPtrTable.hs view
@@ -256,9 +256,9 @@ -- -- @fps@ is a list associating each binding corresponding to a static entry with -- its fingerprint.-sptModuleInitCode :: Module -> [SptEntry] -> SDoc-sptModuleInitCode _ [] = Outputable.empty-sptModuleInitCode this_mod entries = vcat+sptModuleInitCode :: Platform -> Module -> [SptEntry] -> SDoc+sptModuleInitCode _ _ [] = Outputable.empty+sptModuleInitCode platform this_mod entries = vcat [ text "static void hs_spt_init_" <> ppr this_mod <> text "(void) __attribute__((constructor));" , text "static void hs_spt_init_" <> ppr this_mod <> text "(void)"@@ -266,11 +266,11 @@ [ text "static StgWord64 k" <> int i <> text "[2] = " <> pprFingerprint fp <> semi $$ text "extern StgPtr "- <> (ppr $ mkClosureLabel (idName n) (idCafInfo n)) <> semi+ <> (pdoc platform $ mkClosureLabel (idName n) (idCafInfo n)) <> semi $$ text "hs_spt_insert" <> parens (hcat $ punctuate comma [ char 'k' <> int i- , char '&' <> ppr (mkClosureLabel (idName n) (idCafInfo n))+ , char '&' <> pdoc platform (mkClosureLabel (idName n) (idCafInfo n)) ] ) <> semi
compiler/GHC/Iface/UpdateIdInfos.hs view
@@ -8,7 +8,6 @@ import GHC.Core import GHC.Core.InstEnv-import GHC.Driver.Session import GHC.Driver.Types import GHC.StgToCmm.Types (CgInfos (..)) import GHC.Types.Id@@ -28,16 +27,11 @@ -- See Note [Conveying CAF-info and LFInfo between modules] in -- GHC.StgToCmm.Types. updateModDetailsIdInfos- :: DynFlags- -> CgInfos+ :: CgInfos -> ModDetails -- ^ ModDetails to update -> ModDetails -updateModDetailsIdInfos dflags _ mod_details- | gopt Opt_OmitInterfacePragmas dflags- = mod_details--updateModDetailsIdInfos _ cg_infos mod_details =+updateModDetailsIdInfos cg_infos mod_details = let ModDetails{ md_types = type_env -- for unfoldings , md_insts = insts
compiler/GHC/IfaceToCore.hs view
@@ -17,7 +17,7 @@ typecheckIfacesForMerging, typecheckIfaceForInstantiate, tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,- tcIfaceAnnotations, tcIfaceCompleteSigs,+ tcIfaceAnnotations, tcIfaceCompleteMatches, tcIfaceExpr, -- Desired by HERMIT (#7683) tcIfaceGlobal, tcIfaceOneShot@@ -47,7 +47,7 @@ import GHC.Core.FamInstEnv import GHC.Core import GHC.Core.Utils-import GHC.Core.Unfold+import GHC.Core.Unfold.Make import GHC.Core.Lint import GHC.Core.Make import GHC.Types.Id@@ -67,6 +67,7 @@ import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr ) import GHC.Unit.Module import GHC.Types.Unique.FM+import GHC.Types.Unique.DSet ( mkUniqDSet ) import GHC.Types.Unique.Supply import GHC.Utils.Outputable import GHC.Data.Maybe@@ -81,7 +82,6 @@ import qualified GHC.Data.BooleanFormula as BF import Control.Monad-import qualified Data.Map as Map {- This module takes@@ -180,7 +180,7 @@ ; exports <- ifaceExportNames (mi_exports iface) -- Complete Sigs- ; complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)+ ; complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface) -- Finished ; traceIf (vcat [text "Finished typechecking interface for" <+> ppr (mi_module iface),@@ -194,7 +194,7 @@ , md_rules = rules , md_anns = anns , md_exports = exports- , md_complete_sigs = complete_sigs+ , md_complete_matches = complete_matches } } @@ -393,14 +393,14 @@ rules <- tcIfaceRules ignore_prags (mi_rules iface) anns <- tcIfaceAnnotations (mi_anns iface) exports <- ifaceExportNames (mi_exports iface)- complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)+ complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface) return $ ModDetails { md_types = type_env , md_insts = insts , md_fam_insts = fam_insts , md_rules = rules , md_anns = anns , md_exports = exports- , md_complete_sigs = complete_sigs+ , md_complete_matches = complete_matches } return (global_type_env, details) @@ -432,14 +432,14 @@ rules <- tcIfaceRules ignore_prags (mi_rules iface) anns <- tcIfaceAnnotations (mi_anns iface) exports <- ifaceExportNames (mi_exports iface)- complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)+ complete_matches <- tcIfaceCompleteMatches (mi_complete_matches iface) return $ ModDetails { md_types = type_env , md_insts = insts , md_fam_insts = fam_insts , md_rules = rules , md_anns = anns , md_exports = exports- , md_complete_sigs = complete_sigs+ , md_complete_matches = complete_matches } -- Note [Resolving never-exported Names]@@ -792,7 +792,7 @@ Just def -> forkM (mk_at_doc tc) $ extendIfaceTyVarEnv (tyConTyVars tc) $ do { tc_def <- tcIfaceType def- ; return (Just (tc_def, noSrcSpan)) }+ ; return (Just (tc_def, NoATVI)) } -- Must be done lazily in case the RHS of the defaults mention -- the type constructor being defined here -- e.g. type AT a; type AT b = AT [b] #8002@@ -1147,11 +1147,14 @@ ************************************************************************ -} -tcIfaceCompleteSigs :: [IfaceCompleteMatch] -> IfL [CompleteMatch]-tcIfaceCompleteSigs = mapM tcIfaceCompleteSig+tcIfaceCompleteMatches :: [IfaceCompleteMatch] -> IfL [CompleteMatch]+tcIfaceCompleteMatches = mapM tcIfaceCompleteMatch -tcIfaceCompleteSig :: IfaceCompleteMatch -> IfL CompleteMatch-tcIfaceCompleteSig (IfaceCompleteMatch ms t) = return (CompleteMatch ms t)+tcIfaceCompleteMatch :: IfaceCompleteMatch -> IfL CompleteMatch+tcIfaceCompleteMatch (IfaceCompleteMatch ms) =+ mkUniqDSet <$> mapM (forkM doc . tcIfaceConLike) ms+ where+ doc = text "COMPLETE sig" <+> ppr ms {- ************************************************************************@@ -1204,10 +1207,9 @@ -> IfL TyCon tcTupleTyCon in_type sort arity = case sort of- ConstraintTuple -> do { thing <- tcIfaceGlobal (cTupleTyConName arity)- ; return (tyThingTyCon thing) }- BoxedTuple -> return (tupleTyCon Boxed arity)- UnboxedTuple -> return (tupleTyCon Unboxed arity')+ ConstraintTuple -> return (cTupleTyCon arity)+ BoxedTuple -> return (tupleTyCon Boxed arity)+ UnboxedTuple -> return (tupleTyCon Unboxed arity') where arity' | in_type = arity `div` 2 | otherwise = arity -- in expressions, we only have term args@@ -1545,13 +1547,13 @@ tcUnfolding :: TopLevelFlag -> Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr)- = do { dflags <- getDynFlags+ = do { uf_opts <- unfoldingOpts <$> getDynFlags ; mb_expr <- tcPragExpr False toplvl name if_expr ; let unf_src | stable = InlineStable | otherwise = InlineRhs ; return $ case mb_expr of Nothing -> NoUnfolding- Just expr -> mkFinalUnfolding dflags unf_src strict_sig expr+ Just expr -> mkFinalUnfolding uf_opts unf_src strict_sig expr } where -- Strictness should occur before unfolding!@@ -1561,7 +1563,7 @@ = do { mb_expr <- tcPragExpr True toplvl name if_expr ; return (case mb_expr of Nothing -> NoUnfolding- Just expr -> mkCompulsoryUnfolding expr) }+ Just expr -> mkCompulsoryUnfolding' expr) } tcUnfolding toplvl name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr) = do { mb_expr <- tcPragExpr False toplvl name if_expr@@ -1752,7 +1754,7 @@ -- there are a fixed set of CoAxiomRules, -- currently enumerated in typeNatCoAxiomRules tcIfaceCoAxiomRule n- = case Map.lookup n typeNatCoAxiomRules of+ = case lookupUFM typeNatCoAxiomRules n of Just ax -> return ax _ -> pprPanic "tcIfaceCoAxiomRule" (ppr n) @@ -1760,7 +1762,13 @@ tcIfaceDataCon name = do { thing <- tcIfaceGlobal name ; case thing of AConLike (RealDataCon dc) -> return dc- _ -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) }+ _ -> pprPanic "tcIfaceDataCon" (ppr name$$ ppr thing) }++tcIfaceConLike :: Name -> IfL ConLike+tcIfaceConLike name = do { thing <- tcIfaceGlobal name+ ; case thing of+ AConLike cl -> return cl+ _ -> pprPanic "tcIfaceConLike" (ppr name$$ ppr thing) } tcIfaceExtId :: Name -> IfL Id tcIfaceExtId name = do { thing <- tcIfaceGlobal name
compiler/GHC/IfaceToCore.hs-boot view
@@ -11,9 +11,9 @@ import GHC.Driver.Types ( CompleteMatch ) import GHC.Types.Annotations ( Annotation ) -tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing-tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule]-tcIfaceInst :: IfaceClsInst -> IfL ClsInst-tcIfaceFamInst :: IfaceFamInst -> IfL FamInst-tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]-tcIfaceCompleteSigs :: [IfaceCompleteMatch] -> IfL [CompleteMatch]+tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing+tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule]+tcIfaceInst :: IfaceClsInst -> IfL ClsInst+tcIfaceFamInst :: IfaceFamInst -> IfL FamInst+tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]+tcIfaceCompleteMatches :: [IfaceCompleteMatch] -> IfL [CompleteMatch]
compiler/GHC/Rename/Expr.hs view
@@ -243,7 +243,6 @@ where rn_prag :: HsPragE GhcPs -> HsPragE GhcRn rn_prag (HsPragSCC x1 src ann) = HsPragSCC x1 src ann- rn_prag (HsPragTick x1 src info srcInfo) = HsPragTick x1 src info srcInfo rnExpr (HsLam x matches) = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches
compiler/GHC/Rename/HsType.hs view
@@ -52,14 +52,13 @@ import GHC.Tc.Utils.Monad import GHC.Types.Name.Reader import GHC.Builtin.Names-import GHC.Builtin.Types.Prim ( funTyConName ) import GHC.Types.Name import GHC.Types.SrcLoc import GHC.Types.Name.Set import GHC.Types.FieldLabel import GHC.Utils.Misc-import GHC.Types.Basic ( compareFixity, funTyFixity, negateFixity+import GHC.Types.Basic ( compareFixity, negateFixity , Fixity(..), FixityDirection(..), LexicalFixity(..) , TypeOrKind(..) ) import GHC.Utils.Outputable@@ -168,7 +167,7 @@ ; let nwc_rdrs = nubL nwc_rdrs' ; implicit_bndrs <- case scoping of AlwaysBind -> pure tv_rdrs- BindUnlessForall -> forAllOrNothing (isLHsForAllTy hs_ty) tv_rdrs+ BindUnlessForall -> forAllOrNothing (isLHsInvisForAllTy hs_ty) tv_rdrs NeverBind -> pure [] ; rnImplicitBndrs Nothing implicit_bndrs $ \ vars -> do { (wcs, hs_ty', fvs1) <- rnWcBody ctxt nwc_rdrs hs_ty@@ -321,7 +320,7 @@ rnHsSigType ctx level (HsIB { hsib_body = hs_ty }) = do { traceRn "rnHsSigType" (ppr hs_ty) ; rdr_env <- getLocalRdrEnv- ; vars0 <- forAllOrNothing (isLHsForAllTy hs_ty)+ ; vars0 <- forAllOrNothing (isLHsInvisForAllTy hs_ty) $ filterInScope rdr_env $ extractHsTyRdrTyVars hs_ty ; rnImplicitBndrs Nothing vars0 $ \ vars ->@@ -331,18 +330,44 @@ , hsib_body = body' } , fvs ) } } --- Note [forall-or-nothing rule]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Free variables in signatures are usually bound in an implicit--- 'forall' at the beginning of user-written signatures. However, if the--- signature has an explicit forall at the beginning, this is disabled.------ The idea is nested foralls express something which is only--- expressible explicitly, while a top level forall could (usually) be--- replaced with an implicit binding. Top-level foralls alone ("forall.") are--- therefore an indication that the user is trying to be fastidious, so--- we don't implicitly bind any variables.+{-+Note [forall-or-nothing rule]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Free variables in signatures are usually bound in an implicit 'forall' at the+beginning of user-written signatures. However, if the signature has an+explicit, invisible forall at the beginning, this is disabled. +The idea is nested foralls express something which is only expressible+explicitly, while a top level forall could (usually) be replaced with an+implicit binding. Top-level foralls alone ("forall.") are therefore an+indication that the user is trying to be fastidious, so we don't implicitly+bind any variables.++Note that this rule only applies to outermost /in/visible 'forall's, and not+outermost visible 'forall's. See #18660 for more on this point.++Here are some concrete examples to demonstrate the forall-or-nothing rule in+action:++ type F1 :: a -> b -> b -- Legal; a,b are implicitly quantified.+ -- Equivalently: forall a b. a -> b -> b++ type F2 :: forall a b. a -> b -> b -- Legal; explicitly quantified++ type F3 :: forall a. a -> b -> b -- Illegal; the forall-or-nothing rule says that+ -- if you quantify a, you must also quantify b++ type F4 :: forall a -> b -> b -- Legal; the top quantifier (forall a) is a /visible/+ -- quantifer, so the "nothing" part of the forall-or-nothing+ -- rule applies, and b is therefore implicitly quantified.+ -- Equivalently: forall b. forall a -> b -> b++ type F5 :: forall b. forall a -> b -> c -- Illegal; the forall-or-nothing rule says that+ -- if you quantify b, you must also quantify c++ type F6 :: forall a -> forall b. b -> c -- Legal: just like F4.+-}+ -- | See @Note [forall-or-nothing rule]@. This tiny little function is used -- (rather than its small body inlined) to indicate that we are implementing -- that rule.@@ -574,8 +599,7 @@ ; fix <- lookupTyFixityRn l_op' ; (ty1', fvs2) <- rnLHsTyKi env ty1 ; (ty2', fvs3) <- rnLHsTyKi env ty2- ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy noExtField t1 l_op' t2)- (unLoc l_op') fix ty1' ty2'+ ; res_ty <- mkHsOpTyRn l_op' fix ty1' ty2' ; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) } rnHsTyKi env (HsParTy _ ty)@@ -601,17 +625,10 @@ rnHsTyKi env (HsFunTy _ mult ty1 ty2) = do { (ty1', fvs1) <- rnLHsTyKi env ty1- -- Might find a for-all as the arg of a function type ; (ty2', fvs2) <- rnLHsTyKi env ty2- -- Or as the result. This happens when reading Prelude.hi- -- when we find return :: forall m. Monad m -> forall a. a -> m a-- -- Check for fixity rearrangements ; (mult', w_fvs) <- rnHsArrow env mult- ; res_ty <- mkHsOpTyRn (hs_fun_ty mult') funTyConName funTyFixity ty1' ty2'- ; return (res_ty, fvs1 `plusFV` fvs2 `plusFV` w_fvs) }- where- hs_fun_ty w a b = HsFunTy noExtField w a b+ ; return (HsFunTy noExtField mult' ty1' ty2'+ , plusFVs [fvs1, fvs2, w_fvs]) } rnHsTyKi env listTy@(HsListTy _ ty) = do { data_kinds <- xoptM LangExt.DataKinds@@ -1184,46 +1201,41 @@ a `op` (b `op` c) mkHsOpTyRn rearranges where necessary. The two arguments-have already been renamed and rearranged. It's made rather tiresome-by the presence of ->, which is a separate syntactic construct.+have already been renamed and rearranged.++In the past, mkHsOpTyRn used to handle (->), but this was unnecessary. In the+syntax tree produced by the parser, the arrow already has the least possible+precedence and does not require rearrangement. -} --------------- -- Building (ty1 `op1` (ty21 `op2` ty22))-mkHsOpTyRn :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)- -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn+mkHsOpTyRn :: Located Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn -> RnM (HsType GhcRn) -mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy noExtField ty21 op2 ty22))+mkHsOpTyRn op1 fix1 ty1 (L loc2 (HsOpTy _ ty21 op2 ty22)) = do { fix2 <- lookupTyFixityRn op2- ; mk_hs_op_ty mk1 pp_op1 fix1 ty1- (\t1 t2 -> HsOpTy noExtField t1 op2 t2)- (unLoc op2) fix2 ty21 ty22 loc2 }--mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy _ mult ty21 ty22))- = mk_hs_op_ty mk1 pp_op1 fix1 ty1- hs_fun_ty funTyConName funTyFixity ty21 ty22 loc2- where- hs_fun_ty a b = HsFunTy noExtField mult a b+ ; mk_hs_op_ty op1 fix1 ty1 op2 fix2 ty21 ty22 loc2 } -mkHsOpTyRn mk1 _ _ ty1 ty2 -- Default case, no rearrangment- = return (mk1 ty1 ty2)+mkHsOpTyRn op1 _ ty1 ty2 -- Default case, no rearrangment+ = return (HsOpTy noExtField ty1 op1 ty2) ----------------mk_hs_op_ty :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)- -> Name -> Fixity -> LHsType GhcRn- -> (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)- -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn -> SrcSpan+mk_hs_op_ty :: Located Name -> Fixity -> LHsType GhcRn+ -> Located Name -> Fixity -> LHsType GhcRn+ -> LHsType GhcRn -> SrcSpan -> RnM (HsType GhcRn)-mk_hs_op_ty mk1 op1 fix1 ty1- mk2 op2 fix2 ty21 ty22 loc2- | nofix_error = do { precParseErr (NormalOp op1,fix1) (NormalOp op2,fix2)- ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) }- | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22)))+mk_hs_op_ty op1 fix1 ty1 op2 fix2 ty21 ty22 loc2+ | nofix_error = do { precParseErr (NormalOp (unLoc op1),fix1)+ (NormalOp (unLoc op2),fix2)+ ; return (ty1 `op1ty` (L loc2 (ty21 `op2ty` ty22))) }+ | associate_right = return (ty1 `op1ty` (L loc2 (ty21 `op2ty` ty22))) | otherwise = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)- new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21- ; return (mk2 (noLoc new_ty) ty22) }+ new_ty <- mkHsOpTyRn op1 fix1 ty1 ty21+ ; return (noLoc new_ty `op2ty` ty22) } where+ lhs `op1ty` rhs = HsOpTy noExtField lhs op1 rhs+ lhs `op2ty` rhs = HsOpTy noExtField lhs op2 rhs (nofix_error, associate_right) = compareFixity fix1 fix2
compiler/GHC/Rename/Module.hs view
@@ -1895,15 +1895,25 @@ (L loc (HsDerivingClause { deriv_clause_ext = noExtField , deriv_clause_strategy = dcs- , deriv_clause_tys = L loc' dct }))+ , deriv_clause_tys = dct })) = do { (dcs', dct', fvs)- <- rnLDerivStrategy doc dcs $ mapFvRn rn_clause_pred dct+ <- rnLDerivStrategy doc dcs $ rn_deriv_clause_tys dct ; warnNoDerivStrat dcs' loc ; pure ( L loc (HsDerivingClause { deriv_clause_ext = noExtField , deriv_clause_strategy = dcs'- , deriv_clause_tys = L loc' dct' })+ , deriv_clause_tys = dct' }) , fvs ) } where+ rn_deriv_clause_tys :: LDerivClauseTys GhcPs+ -> RnM (LDerivClauseTys GhcRn, FreeVars)+ rn_deriv_clause_tys (L l dct) = case dct of+ DctSingle x ty -> do+ (ty', fvs) <- rn_clause_pred ty+ pure (L l (DctSingle x ty'), fvs)+ DctMulti x tys -> do+ (tys', fvs) <- mapFvRn rn_clause_pred tys+ pure (L l (DctMulti x tys'), fvs)+ rn_clause_pred :: LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars) rn_clause_pred pred_ty = do let inf_err = Just (text "Inferred type variables are not allowed")
compiler/GHC/Rename/Names.hs view
@@ -58,7 +58,7 @@ import GHC.Data.Maybe import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Basic ( TopLevelFlag(..), StringLiteral(..) )-import GHC.Utils.Misc+import GHC.Utils.Misc as Utils import GHC.Utils.Panic import GHC.Data.FastString import GHC.Data.FastString.Env@@ -1186,8 +1186,8 @@ mkChildEnv gres = foldr add emptyNameEnv gres where add gre env = case gre_par gre of- FldParent p _ -> extendNameEnv_Acc (:) singleton env p gre- ParentIs p -> extendNameEnv_Acc (:) singleton env p gre+ FldParent p _ -> extendNameEnv_Acc (:) Utils.singleton env p gre+ ParentIs p -> extendNameEnv_Acc (:) Utils.singleton env p gre NoParent -> env findChildren :: NameEnv [a] -> Name -> [a]
compiler/GHC/Rename/Pat.hs view
@@ -749,7 +749,7 @@ = do { let lbl = rdrNameAmbiguousFieldOcc f ; sel <- setSrcSpan loc $ -- Defer renaming of overloaded fields to the typechecker- -- See Note [Disambiguating record fields] in GHC.Tc.Gen.Expr+ -- See Note [Disambiguating record fields] in GHC.Tc.Gen.Head if overload_ok then do { mb <- lookupGlobalOccRn_overloaded overload_ok lbl
compiler/GHC/Runtime/Eval.hs view
@@ -81,7 +81,6 @@ import GHC.Runtime.Linker as Linker import GHC.Driver.Session import GHC.Driver.Ppr-import GHC.LanguageExtensions import GHC.Types.Unique import GHC.Types.Unique.Supply import GHC.Utils.Monad@@ -97,8 +96,8 @@ import GHC.Data.FastString import GHC.Data.Bag import GHC.Utils.Misc-import qualified GHC.Parser.Lexer as Lexer (P (..), ParseResult(..), unP, mkPStatePure)-import GHC.Parser.Lexer (ParserFlags)+import qualified GHC.Parser.Lexer as Lexer (P (..), ParseResult(..), unP, initParserState)+import GHC.Parser.Lexer (ParserOpts) import qualified GHC.Parser as Parser (parseStmt, parseModule, parseDeclaration, parseImport) import System.Directory@@ -878,14 +877,14 @@ ; hscTcRnLookupRdrName hsc_env lrdr_name } -- | Returns @True@ if passed string is a statement.-isStmt :: ParserFlags -> String -> Bool+isStmt :: ParserOpts -> String -> Bool isStmt pflags stmt = case parseThing Parser.parseStmt pflags stmt of Lexer.POk _ _ -> True Lexer.PFailed _ -> False -- | Returns @True@ if passed string has an import declaration.-hasImport :: ParserFlags -> String -> Bool+hasImport :: ParserOpts -> String -> Bool hasImport pflags stmt = case parseThing Parser.parseModule pflags stmt of Lexer.POk _ thing -> hasImports thing@@ -894,14 +893,14 @@ hasImports = not . null . hsmodImports . unLoc -- | Returns @True@ if passed string is an import declaration.-isImport :: ParserFlags -> String -> Bool+isImport :: ParserOpts -> String -> Bool isImport pflags stmt = case parseThing Parser.parseImport pflags stmt of Lexer.POk _ _ -> True Lexer.PFailed _ -> False -- | Returns @True@ if passed string is a declaration but __/not a splice/__.-isDecl :: ParserFlags -> String -> Bool+isDecl :: ParserOpts -> String -> Bool isDecl pflags stmt = do case parseThing Parser.parseDeclaration pflags stmt of Lexer.POk _ thing ->@@ -910,12 +909,12 @@ _ -> True Lexer.PFailed _ -> False -parseThing :: Lexer.P thing -> ParserFlags -> String -> Lexer.ParseResult thing-parseThing parser pflags stmt = do+parseThing :: Lexer.P thing -> ParserOpts -> String -> Lexer.ParseResult thing+parseThing parser opts stmt = do let buf = stringToStringBuffer stmt loc = mkRealSrcLoc (fsLit "<interactive>") 1 1 - Lexer.unP parser (Lexer.mkPStatePure pflags buf loc)+ Lexer.unP parser (Lexer.initParserState opts buf loc) getDocs :: GhcMonad m => Name@@ -1283,10 +1282,7 @@ obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term obtainTermFromId hsc_env bound force id = do hv <- Linker.getHValue hsc_env (varName id)- cvObtainTerm (updEnv hsc_env) bound force (idType id) hv- where updEnv env = env {hsc_dflags = -- #14828- xopt_set (hsc_dflags env) ImpredicativeTypes}- -- See Note [Setting ImpredicativeTypes for :print command]+ cvObtainTerm hsc_env bound force (idType id) hv -- Uses RTTI to reconstruct the type of an Id, making it less polymorphic reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)@@ -1296,39 +1292,3 @@ mkRuntimeUnkTyVar :: Name -> Kind -> TyVar mkRuntimeUnkTyVar name kind = mkTcTyVar name kind RuntimeUnk---{--Note [Setting ImpredicativeTypes for :print command]--If ImpredicativeTypes is not enabled, then `:print <term>` will fail if the-type of <term> has nested `forall`s or `=>`s.-This is because the GHCi debugger's internals will attempt to unify a-metavariable with the type of <term> and then display the result, but if the-type has nested `forall`s or `=>`s, then unification will fail.-As a result, `:print` will bail out and the unhelpful result will be-`<term> = (_t1::t1)` (where `t1` is a metavariable).--Beware: <term> can have nested `forall`s even if its definition doesn't use-RankNTypes! Here is an example from #14828:-- class Functor f where- fmap :: (a -> b) -> f a -> f b--Somewhat surprisingly, `:print fmap` considers the type of fmap to have-nested foralls. This is because the GHCi debugger sees the type-`fmap :: forall f. Functor f => forall a b. (a -> b) -> f a -> f b`.-We could envision deeply instantiating this type to get the type-`forall f a b. Functor f => (a -> b) -> f a -> f b`,-but this trick wouldn't work for higher-rank types.--Instead, we adopt a simpler fix: enable `ImpredicativeTypes` when using-`:print` and friends in the GHCi debugger. This allows metavariables-to unify with types that have nested (or higher-rank) `forall`s/`=>`s,-which makes `:print fmap` display as-`fmap = (_t1::forall a b. Functor f => (a -> b) -> f a -> f b)`, as expected.--Although ImpredicativeTypes is a somewhat unpredictable from a type inference-perspective, there is no danger in using it in the GHCi debugger, since all-of the terms that the GHCi debugger deals with have already been typechecked.--}
compiler/GHC/Runtime/Heap/Inspect.hs view
@@ -559,12 +559,53 @@ liftTcM :: TcM a -> TR a liftTcM = id +-- When we make new unification variables in the GHCi debugger,+-- we use RuntimeUnkTvs. See Note [RuntimeUnkTv]. newVar :: Kind -> TR TcType-newVar = liftTcM . newFlexiTyVarTy+newVar kind = liftTcM (do { tv <- newAnonMetaTyVar RuntimeUnkTv kind+ ; return (mkTyVarTy tv) }) newOpenVar :: TR TcType-newOpenVar = liftTcM newOpenFlexiTyVarTy+newOpenVar = liftTcM (do { kind <- newOpenTypeKind+ ; newVar kind }) +{- Note [RuntimeUnkTv]+~~~~~~~~~~~~~~~~~~~~~~+In the GHCi debugger we use unification variables whose MetaInfo is+RuntimeUnkTv. The special property of a RuntimeUnkTv is that it can+unify with a polytype (see GHC.Tc.Utils.Unify.metaTyVarUpdateOK).+If we don't do this `:print <term>` will fail if the type of <term>+has nested `forall`s or `=>`s.++This is because the GHCi debugger's internals will attempt to unify a+metavariable with the type of <term> and then display the result, but+if the type has nested `forall`s or `=>`s, then unification will fail+unless we do something special. As a result, `:print` will bail out+and the unhelpful result will be `<term> = (_t1::t1)` (where `t1` is a+metavariable).++Beware: <term> can have nested `forall`s even if its definition doesn't use+RankNTypes! Here is an example from #14828:++ class Functor f where+ fmap :: (a -> b) -> f a -> f b++Somewhat surprisingly, `:print fmap` considers the type of fmap to have+nested foralls. This is because the GHCi debugger sees the type+`fmap :: forall f. Functor f => forall a b. (a -> b) -> f a -> f b`.+We could envision deeply instantiating this type to get the type+`forall f a b. Functor f => (a -> b) -> f a -> f b`,+but this trick wouldn't work for higher-rank types.++Instead, we adopt a simpler fix: allow RuntimeUnkTv to unify with a+polytype (specifically, see ghci_tv in GHC.Tc.Utils.Unify.preCheck).+This allows metavariables to unify with types that have+nested (or higher-rank) `forall`s/`=>`s, which makes `:print fmap`+display as+`fmap = (_t1::forall a b. Functor f => (a -> b) -> f a -> f b)`, as expected.+-}++ instTyVars :: [TyVar] -> TR (TCvSubst, [TcTyVar]) -- Instantiate fresh mutable type variables from some TyVars -- This function preserves the print-name, which helps error messages@@ -578,6 +619,10 @@ -- If the TcTyVar has not been refined by the runtime type -- elaboration, then we want to turn it back into the -- original RuntimeUnk+ --+ -- July 20: I'm not convinced that the little dance from+ -- RuntimeUnkTv unification variables to RuntimeUnk skolems+ -- is buying us anything. ToDo: get rid of it. -- | Returns the instantiated type scheme ty', and the -- mapping from new (instantiated) -to- old (skolem) type variables@@ -585,6 +630,7 @@ instScheme (tvs, ty) = do { (subst, tvs') <- instTyVars tvs ; let rtti_inst = [(tv',tv) | (tv',tv) <- tvs' `zip` tvs]+ ; traceTR (text "instScheme" <+> (ppr tvs $$ ppr ty $$ ppr tvs')) ; return (substTy subst ty, rtti_inst) } applyRevSubst :: RttiInstantiation -> TR ()
compiler/GHC/Runtime/Linker.hs view
@@ -929,20 +929,22 @@ ldInputs = concatMap (\l -> [ Option ("-l" ++ l) ]) (nub $ snd <$> temp_sos)- ++ concatMap (\lp -> [ Option ("-L" ++ lp)- , Option "-Xlinker"- , Option "-rpath"- , Option "-Xlinker"- , Option lp ])+ ++ concatMap (\lp -> Option ("-L" ++ lp)+ : if gopt Opt_RPath dflags+ then [ Option "-Xlinker"+ , Option "-rpath"+ , Option "-Xlinker"+ , Option lp ]+ else []) (nub $ fst <$> temp_sos) ++ concatMap- (\lp ->- [ Option ("-L" ++ lp)- , Option "-Xlinker"- , Option "-rpath"- , Option "-Xlinker"- , Option lp- ])+ (\lp -> Option ("-L" ++ lp)+ : if gopt Opt_RPath dflags+ then [ Option "-Xlinker"+ , Option "-rpath"+ , Option "-Xlinker"+ , Option lp ]+ else []) minus_big_ls -- See Note [-Xlinker -rpath vs -Wl,-rpath] ++ map (\l -> Option ("-l" ++ l)) minus_ls,@@ -1134,6 +1136,7 @@ -- Note that we want to remove all *local* -- (i.e. non-isExternal) names too (these are the -- temporary bindings from the command line).+ keep_name :: (Name, a) -> Bool keep_name (n,_) = isExternalName n && nameModule n `elemModuleSet` bcos_retained
compiler/GHC/Settings/IO.hs view
@@ -115,6 +115,8 @@ windres_path <- getToolSetting "windres command" libtool_path <- getToolSetting "libtool command" ar_path <- getToolSetting "ar command"+ otool_path <- getToolSetting "otool command"+ install_name_tool_path <- getToolSetting "install_name_tool command" ranlib_path <- getToolSetting "ranlib command" -- TODO this side-effect doesn't belong here. Reading and parsing the settings@@ -137,7 +139,7 @@ as_args = map Option cc_args ld_prog = cc_prog ld_args = map Option (cc_args ++ words cc_link_args_str)- ld_r_prog <- getSetting "Merge objects command"+ ld_r_prog <- getToolSetting "Merge objects command" ld_r_args <- getSetting "Merge objects flags" llvmTarget <- getSetting "LLVM target"@@ -191,6 +193,8 @@ , toolSettings_pgm_windres = windres_path , toolSettings_pgm_libtool = libtool_path , toolSettings_pgm_ar = ar_path+ , toolSettings_pgm_otool = otool_path+ , toolSettings_pgm_install_name_tool = install_name_tool_path , toolSettings_pgm_ranlib = ranlib_path , toolSettings_pgm_lo = (lo_prog,[]) , toolSettings_pgm_lc = (lc_prog,[])
compiler/GHC/Stg/Lint.hs view
@@ -164,7 +164,7 @@ lintStgExpr expr lintStgRhs rhs@(StgRhsCon _ con args) = do- when (isUnboxedTupleCon con || isUnboxedSumCon con) $ do+ when (isUnboxedTupleDataCon con || isUnboxedSumDataCon con) $ do opts <- getStgPprOpts addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$ pprStgRhs opts rhs)@@ -182,7 +182,7 @@ lintStgExpr app@(StgConApp con args _arg_tys) = do -- unboxed sums should vanish during unarise lf <- getLintFlags- when (lf_unarised lf && isUnboxedSumCon con) $ do+ when (lf_unarised lf && isUnboxedSumDataCon con) $ do opts <- getStgPprOpts addErrL (text "Unboxed sum after unarise:" $$ pprStgExpr opts app)
compiler/GHC/Stg/Unarise.hs view
@@ -294,7 +294,7 @@ return (StgRhsClosure ext ccs update_flag args1 expr') unariseRhs rho (StgRhsCon ccs con args)- = ASSERT(not (isUnboxedTupleCon con || isUnboxedSumCon con))+ = ASSERT(not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con)) return (StgRhsCon ccs con (unariseConArgs rho args)) --------------------------------------------------------------------------------@@ -372,10 +372,10 @@ -- Doesn't return void args. unariseMulti_maybe :: UnariseEnv -> DataCon -> [InStgArg] -> [Type] -> Maybe [OutStgArg] unariseMulti_maybe rho dc args ty_args- | isUnboxedTupleCon dc+ | isUnboxedTupleDataCon dc = Just (unariseConArgs rho args) - | isUnboxedSumCon dc+ | isUnboxedSumDataCon dc , let args1 = ASSERT(isSingleton args) (unariseConArgs rho args) = Just (mkUbxSum dc ty_args args1)
compiler/GHC/StgToCmm/Bind.hs view
@@ -755,14 +755,15 @@ -- name of the data constructor itself. Otherwise it is determined by -- @closureDescription@ from the let binding information. -closureDescription :: DynFlags- -> Module -- Module- -> Name -- Id of closure binding- -> String+closureDescription+ :: DynFlags+ -> Module -- Module+ -> Name -- Id of closure binding+ -> String -- Not called for StgRhsCon which have global info tables built in -- CgConTbls.hs with a description generated from the data constructor closureDescription dflags mod_name name- = showSDocDump dflags (char '<' <>+ = showSDocDump (initSDocContext dflags defaultDumpStyle) (char '<' <> (if isExternalName name then ppr name -- ppr will include the module name prefix else pprModule mod_name <> char '.' <> ppr name) <>
compiler/GHC/StgToCmm/Closure.hs view
@@ -1,5 +1,10 @@-{-# LANGUAGE CPP, RecordWildCards #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-} + ----------------------------------------------------------------------------- -- -- Stg to C-- code generation:@@ -114,9 +119,13 @@ -- To tail-call it, assign to these locals, -- and branch to the block id -instance Outputable CgLoc where- ppr (CmmLoc e) = text "cmm" <+> ppr e- ppr (LneLoc b rs) = text "lne" <+> ppr b <+> ppr rs+instance OutputableP Platform CgLoc where+ pdoc = pprCgLoc++pprCgLoc :: Platform -> CgLoc -> SDoc+pprCgLoc platform = \case+ CmmLoc e -> text "cmm" <+> pdoc platform e+ LneLoc b rs -> text "lne" <+> ppr b <+> ppr rs type SelfLoopInfo = (Id, BlockId, [LocalReg])
compiler/GHC/StgToCmm/DataCon.hs view
@@ -354,7 +354,7 @@ -- binders args, assuming that we have just returned from a 'case' which -- found a con bindConArgs (DataAlt con) base args- = ASSERT(not (isUnboxedTupleCon con))+ = ASSERT(not (isUnboxedTupleDataCon con)) do profile <- getProfile platform <- getPlatform let (_, _, args_w_offsets) = mkVirtConstrOffsets profile (addIdReps args)
compiler/GHC/StgToCmm/Expr.hs view
@@ -837,7 +837,7 @@ cgConApp :: DataCon -> [StgArg] -> FCode ReturnKind cgConApp con stg_args- | isUnboxedTupleCon con -- Unboxed tuple: assign and return+ | isUnboxedTupleDataCon con -- Unboxed tuple: assign and return = do { arg_exprs <- getNonVoidArgAmodes stg_args ; tickyUnboxedTupleReturn (length arg_exprs) ; emitReturn arg_exprs }
compiler/GHC/StgToCmm/Layout.hs view
@@ -204,7 +204,7 @@ r <- direct_call "slow_call" NativeNodeCall (mkRtsApFastLabel rts_fun) arity ((P,Just fun):argsreps) emitComment $ mkFastString ("slow_call for " ++- showSDoc dflags (ppr fun) +++ showSDoc dflags (pdoc platform fun) ++ " with pat " ++ unpackFS rts_fun) return r @@ -291,10 +291,11 @@ direct_call caller call_conv lbl arity args | debugIsOn && args `lengthLessThan` real_arity -- Too few args = do -- Caller should ensure that there enough args!+ platform <- getPlatform pprPanic "direct_call" $ text caller <+> ppr arity <+>- ppr lbl <+> ppr (length args) <+>- ppr (map snd args) <+> ppr (map fst args)+ pdoc platform lbl <+> ppr (length args) <+>+ pdoc platform (map snd args) <+> ppr (map fst args) | null rest_args -- Precisely the right number of arguments = emitCall (call_conv, NativeReturn) target (nonVArgs args)
compiler/GHC/StgToCmm/Monad.hs view
@@ -1,6 +1,9 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-} + ----------------------------------------------------------------------------- -- -- Monad for Stg to C-- code generation@@ -182,9 +185,9 @@ , cg_loc :: CgLoc -- CmmExpr for the *tagged* value } -instance Outputable CgIdInfo where- ppr (CgIdInfo { cg_id = id, cg_loc = loc })- = ppr id <+> text "-->" <+> ppr loc+instance OutputableP Platform CgIdInfo where+ pdoc env (CgIdInfo { cg_id = id, cg_loc = loc })+ = ppr id <+> text "-->" <+> pdoc env loc -- Sequel tells what to do with the result of this expression data Sequel
compiler/GHC/StgToCmm/Prim.hs view
@@ -840,9 +840,9 @@ emitCtzCall res w (wordWidth platform) -- Unsigned int to floating point conversions- Word2FloatOp -> \[w] -> opIntoRegs $ \[res] -> do+ WordToFloatOp -> \[w] -> opIntoRegs $ \[res] -> do emitPrimCall [res] (MO_UF_Conv W32) [w]- Word2DoubleOp -> \[w] -> opIntoRegs $ \[res] -> do+ WordToDoubleOp -> \[w] -> opIntoRegs $ \[res] -> do emitPrimCall [res] (MO_UF_Conv W64) [w] -- Atomic operations@@ -1056,10 +1056,10 @@ -- The rest just translate straightforwardly - Int2WordOp -> \args -> opNop args- Word2IntOp -> \args -> opNop args- Int2AddrOp -> \args -> opNop args- Addr2IntOp -> \args -> opNop args+ IntToWordOp -> \args -> opNop args+ WordToIntOp -> \args -> opNop args+ IntToAddrOp -> \args -> opNop args+ AddrToIntOp -> \args -> opNop args ChrOp -> \args -> opNop args -- Int# and Char# are rep'd the same OrdOp -> \args -> opNop args @@ -1309,14 +1309,14 @@ -- Conversions - Int2DoubleOp -> \args -> opTranslate args (MO_SF_Conv (wordWidth platform) W64)- Double2IntOp -> \args -> opTranslate args (MO_FS_Conv W64 (wordWidth platform))+ IntToDoubleOp -> \args -> opTranslate args (MO_SF_Conv (wordWidth platform) W64)+ DoubleToIntOp -> \args -> opTranslate args (MO_FS_Conv W64 (wordWidth platform)) - Int2FloatOp -> \args -> opTranslate args (MO_SF_Conv (wordWidth platform) W32)- Float2IntOp -> \args -> opTranslate args (MO_FS_Conv W32 (wordWidth platform))+ IntToFloatOp -> \args -> opTranslate args (MO_SF_Conv (wordWidth platform) W32)+ FloatToIntOp -> \args -> opTranslate args (MO_FS_Conv W32 (wordWidth platform)) - Float2DoubleOp -> \args -> opTranslate args (MO_FF_Conv W32 W64)- Double2FloatOp -> \args -> opTranslate args (MO_FF_Conv W64 W32)+ FloatToDoubleOp -> \args -> opTranslate args (MO_FF_Conv W32 W64)+ DoubleToFloatOp -> \args -> opTranslate args (MO_FF_Conv W64 W32) -- Word comparisons masquerading as more exotic things.
compiler/GHC/StgToCmm/Utils.hs view
@@ -364,7 +364,7 @@ emitMultiAssign [reg] [rhs] = emitAssign (CmmLocal reg) rhs emitMultiAssign regs rhss = do platform <- getPlatform- ASSERT2( equalLength regs rhss, ppr regs $$ ppr rhss )+ ASSERT2( equalLength regs rhss, ppr regs $$ pdoc platform rhss ) unscramble platform ([1..] `zip` (regs `zip` rhss)) unscramble :: Platform -> [Vrtx] -> FCode ()
compiler/GHC/SysTools.hs view
@@ -43,6 +43,7 @@ import GHC.Settings.Utils import GHC.Unit+import GHC.Unit.State import GHC.Utils.Error import GHC.Utils.Panic import GHC.Utils.Outputable@@ -138,15 +139,17 @@ -> IO LlvmConfig lazyInitLlvmConfig top_dir = unsafeInterleaveIO $ do -- see Note [LLVM configuration]- targets <- readAndParse "llvm-targets" mkLlvmTarget- passes <- readAndParse "llvm-passes" id- return $ LlvmConfig { llvmTargets = targets, llvmPasses = passes }+ targets <- readAndParse "llvm-targets"+ passes <- readAndParse "llvm-passes"+ return $ LlvmConfig { llvmTargets = fmap mkLlvmTarget <$> targets,+ llvmPasses = passes } where- readAndParse name builder =+ readAndParse :: Read a => String -> IO a+ readAndParse name = do let llvmConfigFile = top_dir </> name llvmConfigStr <- readFile llvmConfigFile case maybeReadFuzzy llvmConfigStr of- Just s -> return (fmap builder <$> s)+ Just s -> return s Nothing -> pgmError ("Can't parse " ++ show llvmConfigFile) mkLlvmTarget :: (String, String, String) -> LlvmTarget@@ -259,7 +262,10 @@ | ( osElfTarget (platformOS (targetPlatform dflags)) || osMachOTarget (platformOS (targetPlatform dflags)) ) && dynLibLoader dflags == SystemDependent &&- WayDyn `Set.member` ways dflags+ -- Only if we want dynamic libraries+ WayDyn `Set.member` ways dflags &&+ -- Only use RPath if we explicitly asked for it+ gopt Opt_RPath dflags = ["-L" ++ l, "-Xlinker", "-rpath", "-Xlinker", l] -- See Note [-Xlinker -rpath vs -Wl,-rpath] | otherwise = ["-L" ++ l]@@ -384,8 +390,15 @@ ++ map Option pkg_lib_path_opts ++ map Option pkg_link_opts ++ map Option pkg_framework_opts- ++ [ Option "-Wl,-dead_strip_dylibs" ]+ -- dead_strip_dylibs, will remove unused dylibs, and thus save+ -- space in the load commands. The -headerpad is necessary so+ -- that we can inject more @rpath's later for the leftover+ -- libraries in the runInjectRpaths phase below.+ --+ -- See Note [Dynamic linking on macOS]+ ++ [ Option "-Wl,-dead_strip_dylibs", Option "-Wl,-headerpad,8000" ] )+ runInjectRPaths dflags pkg_lib_paths output_fn _ -> do ------------------------------------------------------------------- -- Making a DSO
compiler/GHC/SysTools/Tasks.hs view
@@ -28,6 +28,10 @@ import GHC.SysTools.Process import GHC.SysTools.Info +import Control.Monad (join, forM, filterM)+import System.Directory (doesFileExist)+import System.FilePath ((</>))+ {- ************************************************************************ * *@@ -237,6 +241,41 @@ return Nothing) +-- | On macOS we rely on the linkers @-dead_strip_dylibs@ flag to remove unused+-- libraries from the dynamic library. We do this to reduce the number of load+-- commands that end up in the dylib, and has been limited to 32K (32768) since+-- macOS Sierra (10.14).+--+-- @-dead_strip_dylibs@ does not dead strip @-rpath@ entries, as such passing+-- @-l@ and @-rpath@ to the linker will result in the unnecesasry libraries not+-- being included in the load commands, however the @-rpath@ entries are all+-- forced to be included. This can lead to 100s of @-rpath@ entries being+-- included when only a handful of libraries end up being truely linked.+--+-- Thus after building the library, we run a fixup phase where we inject the+-- @-rpath@ for each found library (in the given library search paths) into the+-- dynamic library through @-add_rpath@.+--+-- See Note [Dynamic linking on macOS]+runInjectRPaths :: DynFlags -> [FilePath] -> FilePath -> IO ()+runInjectRPaths dflags lib_paths dylib = do+ info <- lines <$> askOtool dflags Nothing [Option "-L", Option dylib]+ -- filter the output for only the libraries. And then drop the @rpath prefix.+ let libs = fmap (drop 7) $ filter (isPrefixOf "@rpath") $ fmap (head.words) $ info+ -- find any pre-existing LC_PATH items+ info <- fmap words.lines <$> askOtool dflags Nothing [Option "-l", Option dylib]+ let paths = concatMap f info+ where f ("path":p:_) = [p]+ f _ = []+ lib_paths' = [ p | p <- lib_paths, not (p `elem` paths) ]+ -- only find those rpaths, that aren't already in the library.+ rpaths <- nub.sort.join <$> forM libs (\f -> filterM (\l -> doesFileExist (l </> f)) lib_paths')+ -- inject the rpaths+ case rpaths of+ [] -> return ()+ _ -> runInstallNameTool dflags $ map Option $ "-add_rpath":(intersperse "-add_rpath" rpaths) ++ [dylib]++ runLink :: DynFlags -> [Option] -> IO () runLink dflags args = traceToolCommand dflags "linker" $ do -- See Note [Run-time linker info]@@ -328,6 +367,17 @@ runAr dflags cwd args = traceToolCommand dflags "ar" $ do let ar = pgm_ar dflags runSomethingFiltered dflags id "Ar" ar args cwd Nothing++askOtool :: DynFlags -> Maybe FilePath -> [Option] -> IO String+askOtool dflags mb_cwd args = do+ let otool = pgm_otool dflags+ runSomethingWith dflags "otool" otool args $ \real_args ->+ readCreateProcessWithExitCode' (proc otool real_args){ cwd = mb_cwd }++runInstallNameTool :: DynFlags -> [Option] -> IO ()+runInstallNameTool dflags args = do+ let tool = pgm_install_name_tool dflags+ runSomethingFiltered dflags id "Install Name Tool" tool args Nothing Nothing runRanlib :: DynFlags -> [Option] -> IO () runRanlib dflags args = traceToolCommand dflags "ranlib" $ do
compiler/GHC/Tc/Deriv.hs view
@@ -437,17 +437,22 @@ -> TcM [EarlyDerivSpec] makeDerivSpecs deriv_infos deriv_decls = do { eqns1 <- sequenceA- [ deriveClause rep_tc scoped_tvs dcs preds err_ctxt+ [ deriveClause rep_tc scoped_tvs dcs (deriv_clause_preds dct) err_ctxt | DerivInfo { di_rep_tc = rep_tc , di_scoped_tvs = scoped_tvs , di_clauses = clauses , di_ctxt = err_ctxt } <- deriv_infos , L _ (HsDerivingClause { deriv_clause_strategy = dcs- , deriv_clause_tys = L _ preds })+ , deriv_clause_tys = dct }) <- clauses ] ; eqns2 <- mapM (recoverM (pure Nothing) . deriveStandalone) deriv_decls ; return $ concat eqns1 ++ catMaybes eqns2 }+ where+ deriv_clause_preds :: LDerivClauseTys GhcRn -> [LHsSigType GhcRn]+ deriv_clause_preds (L _ dct) = case dct of+ DctSingle _ ty -> [ty]+ DctMulti _ tys -> tys ------------------------------------------------------------------ -- | Process the derived classes in a single @deriving@ clause.
compiler/GHC/Tc/Deriv/Generate.hs view
@@ -1691,19 +1691,14 @@ @(T x -> forall b. b -> b) op -The use of type applications is crucial here. If we had tried using only-explicit type signatures, like so:-- instance C <rep-ty> => C (T x) where- op :: T x -> forall b. b -> b- op = coerce (op :: <rep-ty> -> forall b. b -> b)+The use of type applications is crucial here. We have to instantiate+both type args of (coerce :: Coercible a b => a -> b) to polytypes,+and we can only do that with VTA or Quick Look. Here VTA seems more+appropriate for machine generated code: it's simple and robust. -Then GHC will attempt to deeply skolemize the two type signatures, which will-wreak havoc with the Coercible solver. Therefore, we instead use type-applications, which do not deeply skolemize and thus avoid this issue.-The downside is that we currently require -XImpredicativeTypes to permit this-polymorphic type instantiation, so we have to switch that flag on locally in-GHC.Tc.Deriv.genInst. See #8503 for more discussion.+However, to allow VTA with polytypes we must switch on+-XImpredicativeTypes locally in GHC.Tc.Deriv.genInst.+See #8503 for more discussion. Note [Newtype-deriving trickiness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1807,9 +1802,8 @@ c = coerce @(Int -> forall b. b -> Int) c -That is because the instance signature deeply skolemizes the forall-bound-`b`, which wreaks havoc with the `Coercible` solver. An additional visible type-argument of @(Int -> forall b. b -> Age) is enough to prevent this.+That is because we still need to instantiate the second argument of+coerce with a polytype, and we can only do that with VTA or QuickLook. Be aware that the use of an instance signature doesn't /solve/ this problem; it just makes it less likely to occur. For example, if a class has
compiler/GHC/Tc/Errors.hs view
@@ -69,7 +69,7 @@ import Control.Monad ( when ) import Data.Foldable ( toList )-import Data.List ( partition, mapAccumL, nub, sortBy, unfoldr )+import Data.List ( partition, mapAccumL, sortBy, unfoldr ) import {-# SOURCE #-} GHC.Tc.Errors.Hole ( findValidHoleFits ) @@ -215,7 +215,13 @@ -- If we are deferring we are going to need /all/ evidence around, -- including the evidence produced by unflattening (zonkWC) ; let tidy_env = tidyFreeTyCoVars emptyTidyEnv free_tvs- free_tvs = tyCoVarsOfWCList wanted+ free_tvs = filterOut isCoVar $+ tyCoVarsOfWCList wanted+ -- tyCoVarsOfWC returns free coercion *holes*, even though+ -- they are "bound" by other wanted constraints. They in+ -- turn may mention variables bound further in, which makes+ -- no sense. Really we should not return those holes at all;+ -- for now we just filter them out. ; traceTc "reportUnsolved (after zonking):" $ vcat [ text "Free tyvars:" <+> pprTyVars free_tvs@@ -832,7 +838,11 @@ _ -> pprPanic "mkSkolReporter" (ppr ct1 $$ ppr ct2) cmp_loc :: Ct -> Ct -> Ordering-cmp_loc ct1 ct2 = ctLocSpan (ctLoc ct1) `compare` ctLocSpan (ctLoc ct2)+cmp_loc ct1 ct2 = get ct1 `compare` get ct2+ where+ get ct = realSrcSpanStart (ctLocSpan (ctLoc ct))+ -- Reduce duplication by reporting only one error from each+ -- /starting/ location even if the end location differs reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter reportGroup mk_err ctxt cts =@@ -1451,14 +1461,15 @@ ; mkTyVarEqErr' dflags ctxt report ct tv1 ty2 } mkTyVarEqErr' dflags ctxt report ct tv1 ty2- | isUserSkolem ctxt tv1 -- ty2 won't be a meta-tyvar; we would have- -- swapped in Solver.Canonical.canEqTyVarHomo+ | isSkolemTyVar tv1 -- ty2 won't be a meta-tyvar; we would have+ -- swapped in Solver.Canonical.canEqTyVarHomo || isTyVarTyVar tv1 && not (isTyVarTy ty2) || ctEqRel ct == ReprEq -- The cases below don't really apply to ReprEq (except occurs check) = mkErrorMsgFromCt ctxt ct $ mconcat [ headline_msg , extraTyVarEqInfo ctxt tv1 ty2+ , suggestAddSig ctxt ty1 ty2 , report ] @@ -1594,17 +1605,6 @@ <+> text "is a non-injective type family" | otherwise = empty -isUserSkolem :: ReportErrCtxt -> TcTyVar -> Bool--- See Note [Reporting occurs-check errors]-isUserSkolem ctxt tv- = isSkolemTyVar tv && any is_user_skol_tv (cec_encl ctxt)- where- is_user_skol_tv (Implic { ic_skols = sks, ic_info = skol_info })- = tv `elem` sks && is_user_skol_info skol_info-- is_user_skol_info (InferSkol {}) = False- is_user_skol_info _ = True- misMatchOrCND :: Bool -> ReportErrCtxt -> Ct -> TcType -> TcType -> Report -- If oriented then ty1 is actual, ty2 is expected@@ -1724,22 +1724,30 @@ suggestAddSig :: ReportErrCtxt -> TcType -> TcType -> Report -- See Note [Suggest adding a type signature]-suggestAddSig ctxt ty1 ty2- | null inferred_bndrs+suggestAddSig ctxt ty1 _ty2+ | null inferred_bndrs -- No let-bound inferred binders in context = mempty | [bndr] <- inferred_bndrs = important $ text "Possible fix: add a type signature for" <+> quotes (ppr bndr) | otherwise = important $ text "Possible fix: add type signatures for some or all of" <+> (ppr inferred_bndrs) where- inferred_bndrs = nub (get_inf ty1 ++ get_inf ty2)- get_inf ty | Just tv <- tcGetTyVar_maybe ty- , isSkolemTyVar tv- , ((InferSkol prs, _) : _) <- getSkolemInfo (cec_encl ctxt) [tv]- = map fst prs- | otherwise- = []+ inferred_bndrs = case tcGetTyVar_maybe ty1 of+ Just tv | isSkolemTyVar tv -> find (cec_encl ctxt) False tv+ _ -> [] + -- 'find' returns the binders of an InferSkol for 'tv',+ -- provided there is an intervening implication with+ -- ic_no_eqs = False (i.e. a GADT match)+ find [] _ _ = []+ find (implic:implics) seen_eqs tv+ | tv `elem` ic_skols implic+ , InferSkol prs <- ic_info implic+ , seen_eqs+ = map fst prs+ | otherwise+ = find implics (seen_eqs || not (ic_no_eqs implic)) tv+ -------------------- misMatchMsg :: ReportErrCtxt -> Ct -> TcType -> TcType -> Report -- Types are already tidy@@ -2183,9 +2191,8 @@ mod = nameModule nm loc = nameSrcSpan nm -{--Note [Suggest adding a type signature]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{- Note [Suggest adding a type signature]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The OutsideIn algorithm rejects GADT programs that don't have a principal type, and indeed some that do. Example: data T a where@@ -2198,6 +2205,15 @@ untouchable type variable. So suggestAddSig sees if the offending type variable is bound by an *inferred* signature, and suggests adding a declared signature instead.++More specifically, we suggest adding a type sig if we have p ~ ty, and+p is a skolem bound by an InferSkol. Those skolems were created from+unification variables in simplifyInfer. Why didn't we unify? It must+have been because of an intervening GADT or existential, making it+untouchable. Either way, a type signature would help. For GADTs, it+might make it typeable; for existentials the attempt to write a+signature will fail -- or at least will produce a better error message+next time This initially came up in #8968, concerning pattern synonyms.
compiler/GHC/Tc/Errors/Hole.hs view
@@ -44,7 +44,7 @@ import Data.Graph ( graphFromEdges, topSort ) -import GHC.Tc.Solver ( simpl_top, runTcSDeriveds )+import GHC.Tc.Solver ( simplifyTopWanteds, runTcSDeriveds ) import GHC.Tc.Utils.Unify ( tcSubTypeSigma ) import GHC.HsToCore.Docs ( extractDocs )@@ -957,7 +957,7 @@ w_rel_cts = addSimples wanted cloned_relevants final_wc = foldr (setWCAndBinds fresh_binds) w_rel_cts outermost_first ; traceTc "final_wc is: " $ ppr final_wc- ; rem <- runTcSDeriveds $ simpl_top final_wc+ ; rem <- runTcSDeriveds $ simplifyTopWanteds final_wc -- We don't want any insoluble or simple constraints left, but -- solved implications are ok (and necessary for e.g. undefined) ; traceTc "rems was:" $ ppr rem
+ compiler/GHC/Tc/Gen/App.hs view
@@ -0,0 +1,1088 @@+{-+%+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++{-# LANGUAGE CPP, TupleSections, ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies, DataKinds, GADTs, TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module GHC.Tc.Gen.App+ ( tcApp+ , tcInferSigma+ , tcValArg+ , tcExprPrag ) where++import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcCheckPolyExprNC )++import GHC.Builtin.Types (multiplicityTy)+import GHC.Tc.Gen.Head+import GHC.Hs+import GHC.Tc.Utils.Monad+import GHC.Tc.Utils.Unify+import GHC.Tc.Utils.Instantiate+import GHC.Tc.Instance.Family ( tcGetFamInstEnvs, tcLookupDataFamInst_maybe )+import GHC.Tc.Gen.HsType+import GHC.Tc.Utils.TcMType+import GHC.Tc.Types.Origin+import GHC.Tc.Utils.TcType as TcType+import GHC.Core.TyCon+import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.Ppr+import GHC.Core.TyCo.Subst (substTyWithInScope)+import GHC.Core.TyCo.FVs( shallowTyCoVarsOfType )+import GHC.Core.Type+import GHC.Tc.Types.Evidence+import GHC.Types.Var.Set+import GHC.Builtin.PrimOps( tagToEnumKey )+import GHC.Builtin.Names+import GHC.Driver.Session+import GHC.Types.SrcLoc+import GHC.Types.Var.Env ( emptyTidyEnv, mkInScopeSet )+import GHC.Data.Maybe+import GHC.Utils.Misc+import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic+import qualified GHC.LanguageExtensions as LangExt++import Control.Monad+import Data.Function++#include "GhclibHsVersions.h"++import GHC.Prelude++{- *********************************************************************+* *+ Quick Look overview+* *+********************************************************************* -}++{- Note [Quick Look]+~~~~~~~~~~~~~~~~~~~~+The implementation of Quick Look closely follows the QL paper+ A quick look at impredicativity, Serrano et al, ICFP 2020+ https://www.microsoft.com/en-us/research/publication/a-quick-look-at-impredicativity/++All the moving parts are in this module, GHC.Tc.Gen.App, so named+because it deal with n-ary application. The main workhorse is tcApp.++Some notes relative to the paper++* The "instantiation variables" of the paper are ordinary unification+ variables. We keep track of which variables are instantiation variables+ by keeping a set Delta of instantiation variables.++* When we learn what an instantiation variable must be, we simply unify+ it with that type; this is done in qlUnify, which is the function mgu_ql(t1,t2)+ of the paper. This may fill in a (mutable) instantiation variable with+ a polytype.++* When QL is done, we don't need to turn the un-filled-in+ instantiation variables into unification variables -- they already+ are!++ Moreover, all filled-in occurrences of instantiation variables+ have been zonked away (see "Crucial step" in tcValArgs), and+ so the rest of the type checker never sees a meta-type variable+ filled in with a polytype. For the rest of the typechecker,+ a meta type variable stands (only) for a monotype.++* We cleverly avoid the quadratic cost of QL, alluded to in the paper.+ See Note [Quick Look at value arguments]+-}+++{- *********************************************************************+* *+ tcInferSigma+* *+********************************************************************* -}++tcInferSigma :: Bool -> LHsExpr GhcRn -> TcM TcSigmaType+-- Used only to implement :type; see GHC.Tc.Module.tcRnExpr+-- True <=> instantiate -- return a rho-type+-- False <=> don't instantiate -- return a sigma-type+tcInferSigma inst (L loc rn_expr)+ | (rn_fun, rn_args, _) <- splitHsApps rn_expr+ = addExprCtxt rn_expr $+ setSrcSpan loc $+ do { do_ql <- wantQuickLook rn_fun+ ; (tc_fun, fun_sigma) <- tcInferAppHead rn_fun rn_args Nothing+ ; (_delta, inst_args, app_res_sigma) <- tcInstFun do_ql inst rn_fun fun_sigma rn_args+ ; _tc_args <- tcValArgs do_ql tc_fun inst_args+ ; return app_res_sigma }++{- *********************************************************************+* *+ Typechecking n-ary applications+* *+********************************************************************* -}++{- Note [Application chains and heads]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Quick Look treats application chains specially. What is an+"application chain"? See Fig 2, of the QL paper: "A quick look at+impredicativity" (ICFP'20). Here's the syntax:++app :: head+ | app expr -- HsApp: ordinary application+ | app @type -- HsTypeApp: VTA+ | expr `head` expr -- OpApp: infix applications+ | ( app ) -- HsPar: parens+ | {-# PRAGMA #-} app -- HsPragE: pragmas++head ::= f -- HsVar: variables+ | fld -- HsRecFld: record field selectors+ | (expr :: ty) -- ExprWithTySig: expr with user type sig+ | other_expr -- Other expressions++When tcExpr sees something that starts an application chain (namely,+any of the constructors in 'app' or 'head'), it invokes tcApp to+typecheck it: see Note [tcApp: typechecking applications]. However,+for HsPar and HsPragE, there is no tcWrapResult (which would+instantiate types, bypassing Quick Look), so nothing is gained by+using the application chain route, and we can just recurse to tcExpr.++A "head" has three special cases (for which we can infer a polytype+using tcInferAppHead_maybe); otherwise is just any old expression (for+which we can infer a rho-type (via tcInfer).++There is no special treatment for HsUnboundVar, HsOverLit etc, because+we can't get a polytype from them.++Left and right sections (e.g. (x +) and (+ x)) are not yet supported.+Probably left sections (x +) would be esay to add, since x is the+first arg of (+); but right sections are not so easy. For symmetry+reasons I've left both unchanged, in GHC.Tc.Gen.Expr.++It may not be immediately obvious why ExprWithTySig (e::ty) should be+dealt with by tcApp, even when it is not applied to anything. Consider+ f :: [forall a. a->a] -> Int+ ...(f (undefined :: forall b. b))...+Clearly this should work! But it will /only/ work because if we+instantiate that (forall b. b) impredicatively! And that only happens+in tcApp.++Note [tcApp: typechecking applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+tcApp implements the APP-Downarrow/Uparrow rule of+Fig 3, plus the modification in Fig 5, of the QL paper:+"A quick look at impredicativity" (ICFP'20).++It treats application chains (f e1 @ty e2) specially:++* So we can report errors like "in the third arument of a call of f"++* So we can do Visible Type Application (VTA), for which we must not+ eagerly instantiate the function part of the application.++* So that we can do Quick Look impredicativity.++tcApp works like this:++1. Use splitHsApps, which peels off+ HsApp, HsTypeApp, HsPrag, HsPar+ returning the function in the corner and the arguments++ splitHsApps can deal with infix as well as prefix application,+ and returns a Rebuilder to re-assemble the the application after+ typechecking.++ The "list of arguments" is [HsExprArg], described in Note [HsExprArg].+ in GHC.Tc.Gen.Head++2. Use tcInferAppHead to infer the type of the fuction,+ as an (uninstantiated) TcSigmaType+ There are special cases for+ HsVar, HsRecFld, and ExprWithTySig+ Otherwise, delegate back to tcExpr, which+ infers an (instantiated) TcRhoType++3. Use tcInstFun to instantiate the function, Quick-Looking as we go.+ This implements the |-inst judgement in Fig 4, plus the+ modification in Fig 5, of the QL paper:+ "A quick look at impredicativity" (ICFP'20).++ In tcInstFun we take a quick look at value arguments, using+ quickLookArg. See Note [Quick Look at value arguments].++4. Use quickLookResultType to take a quick look at the result type,+ when in checking mode. This is the shaded part of APP-Downarrow+ in Fig 5.++5. Use tcValArgs to typecheck the value arguments++6. After a gruesome special case for tagToEnum, rebuild the result.+++Some cases that /won't/ work:++1. Consider this (which uses visible type application):++ (let { f :: forall a. a -> a; f x = x } in f) @Int++ Since 'let' is not among the special cases for tcInferAppHead,+ we'll delegate back to tcExpr, which will instantiate f's type+ and the type application to @Int will fail. Too bad!++-}++tcApp :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)+-- See Note [tcApp: typechecking applications]+tcApp rn_expr exp_res_ty+ | (rn_fun, rn_args, rebuild) <- splitHsApps rn_expr+ = do { (tc_fun, fun_sigma) <- tcInferAppHead rn_fun rn_args+ (checkingExpType_maybe exp_res_ty)++ -- Instantiate+ ; do_ql <- wantQuickLook rn_fun+ ; (delta, inst_args, app_res_rho) <- tcInstFun do_ql True rn_fun fun_sigma rn_args++ -- Quick look at result+ ; quickLookResultType do_ql delta app_res_rho exp_res_ty++ ; whenDOptM Opt_D_dump_tc_trace $+ do { inst_args <- mapM zonkArg inst_args -- Only when tracing+ ; traceTc "tcApp" (vcat [ text "rn_fun" <+> ppr rn_fun+ , text "inst_args" <+> brackets (pprWithCommas pprHsExprArgTc inst_args)+ , text "do_ql: " <+> ppr do_ql+ , text "fun_sigma: " <+> ppr fun_sigma+ , text "delta: " <+> ppr delta+ , text "app_res_rho:" <+> ppr app_res_rho+ , text "exp_res_ty:" <+> ppr exp_res_ty+ , text "rn_expr:" <+> ppr rn_expr ]) }++ -- Typecheck the value arguments+ ; tc_args <- tcValArgs do_ql tc_fun inst_args++ -- Special case for tagToEnum#+ ; if isTagToEnum rn_fun+ then tcTagToEnum rn_expr tc_fun tc_args app_res_rho exp_res_ty+ else++ do { -- Reconstruct+ ; let tc_expr = rebuild tc_fun tc_args++ -- Wrap the result+ -- NB: app_res_ty may be a polytype, via zonkQuickLook+ ; addFunResCtxt tc_fun tc_args app_res_rho exp_res_ty $+ tcWrapResult rn_expr tc_expr app_res_rho exp_res_ty } }++--------------------+-- zonkArg is used *only* during debug-tracing, to make it easier to+-- see what is going on. For that reason, it is not a full zonk: add+-- more if you need it.+zonkArg :: HsExprArg 'TcpInst -> TcM (HsExprArg 'TcpInst)+zonkArg eva@(EValArg { eva_arg_ty = Scaled m ty })+ = do { ty' <- zonkTcType ty+ ; return (eva { eva_arg_ty = Scaled m ty' }) }+zonkArg arg = return arg+++wantQuickLook :: HsExpr GhcRn -> TcM Bool+-- GHC switches on impredicativity all the time for ($)+wantQuickLook (HsVar _ f) | unLoc f `hasKey` dollarIdKey = return True+wantQuickLook _ = xoptM LangExt.ImpredicativeTypes+++----------------+tcValArgs :: Bool -- Quick-look on?+ -> HsExpr GhcTc -- The function (for error messages)+ -> [HsExprArg 'TcpInst] -- Actual argument+ -> TcM [HsExprArg 'TcpTc] -- Resulting argument+tcValArgs quick_look fun args+ = go 1 args+ where+ go _ [] = return []+ go n (arg:args) = do { (n',arg') <- tc_arg n arg+ ; args' <- go n' args+ ; return (arg' : args') }++ tc_arg :: Int -> HsExprArg 'TcpInst -> TcM (Int, HsExprArg 'TcpTc)+ tc_arg n (EPar l) = return (n, EPar l)+ tc_arg n (EPrag l p) = return (n, EPrag l (tcExprPrag p))+ tc_arg n (EWrap wrap) = return (n, EWrap wrap)+ tc_arg n (ETypeArg l hs_ty ty) = return (n+1, ETypeArg l hs_ty ty)++ tc_arg n eva@(EValArg { eva_arg = arg, eva_arg_ty = Scaled mult arg_ty })+ = do { -- Crucial step: expose QL results before checking arg_ty+ -- So far as the paper is concerned, this step applies+ -- the poly-substitution Theta, learned by QL, so that we+ -- "see" the polymorphism in that argument type. E.g.+ -- (:) e ids, where ids :: [forall a. a->a]+ -- (:) :: forall p. p->[p]->[p]+ -- Then Theta = [p :-> forall a. a->a], and we want+ -- to check 'e' with expected type (forall a. a->a)+ arg_ty <- if quick_look then zonkTcType arg_ty+ else return arg_ty++ -- Now check the argument+ ; arg' <- addErrCtxt (funAppCtxt fun (eValArgExpr arg) n) $+ tcScalingUsage mult $+ do { traceTc "tcEValArg" $+ vcat [ ppr n <+> text "of" <+> ppr fun+ , text "arg type:" <+> ppr arg_ty+ , text "arg:" <+> ppr arg ]+ ; tcEValArg arg arg_ty }++ ; return (n+1, eva { eva_arg = ValArg arg'+ , eva_arg_ty = Scaled mult arg_ty }) }++tcEValArg :: EValArg 'TcpInst -> TcSigmaType -> TcM (LHsExpr GhcTc)+-- Typecheck one value argument of a function call+tcEValArg (ValArg arg) exp_arg_sigma+ = tcCheckPolyExprNC arg exp_arg_sigma++tcEValArg (ValArgQL { va_expr = L loc _, va_fun = fun, va_args = args+ , va_ty = app_res_rho, va_rebuild = rebuild }) exp_arg_sigma+ = setSrcSpan loc $+ do { traceTc "tcEValArg {" (vcat [ ppr fun <+> ppr args ])+ ; tc_args <- tcValArgs True fun args+ ; co <- unifyType Nothing app_res_rho exp_arg_sigma+ ; traceTc "tcEValArg }" empty+ ; return (L loc $ mkHsWrapCo co $ rebuild fun tc_args) }++----------------+tcValArg :: HsExpr GhcRn -- The function (for error messages)+ -> LHsExpr GhcRn -- Actual argument+ -> Scaled TcSigmaType -- expected arg type+ -> Int -- # of argument+ -> TcM (LHsExpr GhcTc) -- Resulting argument+-- tcValArg is called only from Gen.Expr, dealing with left and right sections+tcValArg fun arg (Scaled mult arg_ty) arg_no+ = addErrCtxt (funAppCtxt fun arg arg_no) $+ tcScalingUsage mult $+ do { traceTc "tcValArg" $+ vcat [ ppr arg_no <+> text "of" <+> ppr fun+ , text "arg type:" <+> ppr arg_ty+ , text "arg:" <+> ppr arg ]+ ; tcCheckPolyExprNC arg arg_ty }+++{- *********************************************************************+* *+ Instantiating the call+* *+********************************************************************* -}++type Delta = TcTyVarSet -- Set of instantiation variables,+ -- written \kappa in the QL paper+ -- Just a set of ordinary unification variables,+ -- but ones that QL may fill in with polytypes++tcInstFun :: Bool -- True <=> Do quick-look+ -> Bool -- False <=> Instantiate only /inferred/ variables at the end+ -- so may return a sigma-typex+ -- True <=> Instantiate all type variables at the end:+ -- return a rho-type+ -- The /only/ call site that passes in False is the one+ -- in tcInferSigma, which is used only to implement :type+ -- Otherwise we do eager instantiation; in Fig 5 of the paper+ -- |-inst returns a rho-type+ -> HsExpr GhcRn -> TcSigmaType -> [HsExprArg 'TcpRn]+ -> TcM ( Delta+ , [HsExprArg 'TcpInst]+ , TcSigmaType )+-- This function implements the |-inst judgement in Fig 4, plus the+-- modification in Fig 5, of the QL paper:+-- "A quick look at impredicativity" (ICFP'20).+tcInstFun do_ql inst_final rn_fun fun_sigma rn_args+ = do { traceTc "tcInstFun" (ppr rn_fun $$ ppr rn_args $$ text "do_ql" <+> ppr do_ql)+ ; go emptyVarSet [] [] fun_sigma rn_args }+ where+ fun_orig = exprCtOrigin rn_fun+ herald = sep [ text "The function" <+> quotes (ppr rn_fun)+ , text "is applied to"]++ -- Count value args only when complaining about a function+ -- applied to too many value args+ -- See Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify.+ n_val_args = count isHsValArg rn_args++ fun_is_out_of_scope -- See Note [VTA for out-of-scope functions]+ = case rn_fun of+ HsUnboundVar {} -> True+ _ -> False++ inst_all :: ArgFlag -> Bool+ inst_all (Invisible {}) = True+ inst_all Required = False++ inst_inferred :: ArgFlag -> Bool+ inst_inferred (Invisible InferredSpec) = True+ inst_inferred (Invisible SpecifiedSpec) = False+ inst_inferred Required = False++ inst_fun :: [HsExprArg 'TcpRn] -> ArgFlag -> Bool+ inst_fun [] | inst_final = inst_all+ | otherwise = inst_inferred+ inst_fun (EValArg {} : _) = inst_all+ inst_fun _ = inst_inferred++ -----------+ go, go1 :: Delta+ -> [HsExprArg 'TcpInst] -- Accumulator, reversed+ -> [Scaled TcSigmaType] -- Value args to which applied so far+ -> TcSigmaType -> [HsExprArg 'TcpRn]+ -> TcM (Delta, [HsExprArg 'TcpInst], TcSigmaType)++ -- go: If fun_ty=kappa, look it up in Theta+ go delta acc so_far fun_ty args+ | Just kappa <- tcGetTyVar_maybe fun_ty+ , kappa `elemVarSet` delta+ = do { cts <- readMetaTyVar kappa+ ; case cts of+ Indirect fun_ty' -> go delta acc so_far fun_ty' args+ Flexi -> go1 delta acc so_far fun_ty args }+ | otherwise+ = go1 delta acc so_far fun_ty args++ -- go1: fun_ty is not filled-in instantiation variable+ -- ('go' dealt with that case)++ -- Rule IALL from Fig 4 of the QL paper+ go1 delta acc so_far fun_ty args+ | (tvs, body1) <- tcSplitSomeForAllTys (inst_fun args) fun_ty+ , (theta, body2) <- tcSplitPhiTy body1+ , not (null tvs && null theta)+ = do { (inst_tvs, wrap, fun_rho) <- setSrcSpanFromArgs rn_args $+ instantiateSigma fun_orig tvs theta body2+ -- setSrcSpanFromArgs: important for the class constraints+ -- that may be emitted from instantiating fun_sigma+ ; go (delta `extendVarSetList` inst_tvs)+ (addArgWrap wrap acc) so_far fun_rho args }+ -- Going around again means we deal easily with+ -- nested forall a. Eq a => forall b. Show b => blah++ -- Rule IRESULT from Fig 4 of the QL paper+ go1 delta acc _ fun_ty []+ = do { traceTc "tcInstFun:ret" (ppr fun_ty)+ ; return (delta, reverse acc, fun_ty) }++ go1 delta acc so_far fun_ty (EPar sp : args)+ = go1 delta (EPar sp : acc) so_far fun_ty args++ go1 delta acc so_far fun_ty (EPrag sp prag : args)+ = go1 delta (EPrag sp prag : acc) so_far fun_ty args++ -- Rule ITYARG from Fig 4 of the QL paper+ go1 delta acc so_far fun_ty ( ETypeArg { eva_loc = loc, eva_hs_ty = hs_ty }+ : rest_args )+ | fun_is_out_of_scope -- See Note [VTA for out-of-scope functions]+ = go delta acc so_far fun_ty rest_args++ | otherwise+ = do { (ty_arg, inst_ty) <- tcVTA fun_ty hs_ty+ ; let arg' = ETypeArg { eva_loc = loc, eva_hs_ty = hs_ty, eva_ty = ty_arg }+ ; go delta (arg' : acc) so_far inst_ty rest_args }++ -- Rule IVAR from Fig 4 of the QL paper:+ go1 delta acc so_far fun_ty args@(EValArg {} : _)+ | Just kappa <- tcGetTyVar_maybe fun_ty+ , kappa `elemVarSet` delta+ = -- Function type was of form f :: forall a b. t1 -> t2 -> b+ -- with 'b', one of the quantified type variables, in the corner+ -- but the call applies it to three or more value args.+ -- Suppose b is instantiated by kappa. Then we want to make fresh+ -- instantiation variables nu1, nu2, and set kappa := nu1 -> nu2+ --+ -- In principle what is happening here is not unlike matchActualFunTysRho+ -- but there are many small differences:+ -- - We know that the function type in unfilled meta-tyvar+ -- matchActualFunTysRho is much more general, has a loop, etc.+ -- - We must be sure to actually update the variable right now,+ -- not defer in any way, because this is a QL instantiation variable.+ -- - We need the freshly allocated unification variables, to extend+ -- delta with.+ -- It's easier just to do the job directly here.+ do { let valArgsCount = countLeadingValArgs args+ ; arg_nus <- replicateM valArgsCount newOpenFlexiTyVar+ -- We need variables for multiplicity (#18731)+ -- Otherwise, 'undefined x' wouldn't be linear in x+ ; mults <- replicateM valArgsCount (newFlexiTyVarTy multiplicityTy)+ ; res_nu <- newOpenFlexiTyVar+ ; kind_co <- unifyKind Nothing liftedTypeKind (tyVarKind kappa)+ ; let delta' = delta `extendVarSetList` (res_nu:arg_nus)+ arg_tys = mkTyVarTys arg_nus+ res_ty = mkTyVarTy res_nu+ fun_ty' = mkVisFunTys (zipWithEqual "tcInstFun" mkScaled mults arg_tys) res_ty+ co_wrap = mkWpCastN (mkTcGReflLeftCo Nominal fun_ty' kind_co)+ acc' = addArgWrap co_wrap acc+ -- Suppose kappa :: kk+ -- Then fun_ty :: kk, fun_ty' :: Type, kind_co :: Type ~ kk+ -- co_wrap :: (fun_ty' |> kind_co) ~ fun_ty'+ ; writeMetaTyVar kappa (mkCastTy fun_ty' kind_co)+ -- kappa is uninstantiated ('go' already checked that)+ ; go delta' acc' so_far fun_ty' args }++ -- Rule IARG from Fig 4 of the QL paper:+ go1 delta acc so_far fun_ty+ (eva@(EValArg { eva_arg = ValArg arg }) : rest_args)+ = do { (wrap, arg_ty, res_ty) <- matchActualFunTySigma herald+ (Just (ppr rn_fun))+ (n_val_args, so_far) fun_ty+ ; let arg_no = 1 + count isVisibleArg acc+ -- We could cache this in a pair with acc; but+ -- it's only evaluated if there's a type error+ ; (delta', arg') <- if do_ql+ then addErrCtxt (funAppCtxt rn_fun arg arg_no) $+ -- Context needed for constraints+ -- generated by calls in arg+ quickLookArg delta arg arg_ty+ else return (delta, ValArg arg)+ ; let acc' = eva { eva_arg = arg', eva_arg_ty = arg_ty }+ : addArgWrap wrap acc+ ; go delta' acc' (arg_ty:so_far) res_ty rest_args }++++{- *********************************************************************+* *+ Visible type application+* *+********************************************************************* -}++tcVTA :: TcType -- Function type+ -> LHsWcType GhcRn -- Argument type+ -> TcM (TcType, TcType)+-- Deal with a visible type application+-- The function type has already had its Inferred binders instantiated+tcVTA fun_ty hs_ty+ | Just (tvb, inner_ty) <- tcSplitForAllTy_maybe fun_ty+ , binderArgFlag tvb == Specified+ -- It really can't be Inferred, because we've just+ -- instantiated those. But, oddly, it might just be Required.+ -- See Note [Required quantifiers in the type of a term]+ = do { let tv = binderVar tvb+ kind = tyVarKind tv+ ; ty_arg <- tcHsTypeApp hs_ty kind++ ; inner_ty <- zonkTcType inner_ty+ -- See Note [Visible type application zonk]++ ; let in_scope = mkInScopeSet (tyCoVarsOfTypes [fun_ty, ty_arg])+ insted_ty = substTyWithInScope in_scope [tv] [ty_arg] inner_ty+ -- NB: tv and ty_arg have the same kind, so this+ -- substitution is kind-respecting+ ; traceTc "VTA" (vcat [ppr tv, debugPprType kind+ , debugPprType ty_arg+ , debugPprType (tcTypeKind ty_arg)+ , debugPprType inner_ty+ , debugPprType insted_ty ])+ ; return (ty_arg, insted_ty) }++ | otherwise+ = do { (_, fun_ty) <- zonkTidyTcType emptyTidyEnv fun_ty+ ; failWith $+ text "Cannot apply expression of type" <+> quotes (ppr fun_ty) $$+ text "to a visible type argument" <+> quotes (ppr hs_ty) }++{- Note [Required quantifiers in the type of a term]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#15859)++ data A k :: k -> Type -- A :: forall k -> k -> Type+ type KindOf (a :: k) = k -- KindOf :: forall k. k -> Type+ a = (undefind :: KindOf A) @Int++With ImpredicativeTypes (thin ice, I know), we instantiate+KindOf at type (forall k -> k -> Type), so+ KindOf A = forall k -> k -> Type+whose first argument is Required++We want to reject this type application to Int, but in earlier+GHCs we had an ASSERT that Required could not occur here.++The ice is thin; c.f. Note [No Required TyCoBinder in terms]+in GHC.Core.TyCo.Rep.++Note [VTA for out-of-scope functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose 'wurble' is not in scope, and we have+ (wurble @Int @Bool True 'x')++Then the renamer will make (HsUnboundVar "wurble) for 'wurble',+and the typechecker will typecheck it with tcUnboundId, giving it+a type 'alpha', and emitting a deferred Hole constraint, to+be reported later.++But then comes the visible type application. If we do nothing, we'll+generate an immediate failure (in tc_app_err), saying that a function+of type 'alpha' can't be applied to Bool. That's insane! And indeed+users complain bitterly (#13834, #17150.)++The right error is the Hole, which has /already/ been emitted by+tcUnboundId. It later reports 'wurble' as out of scope, and tries to+give its type.++Fortunately in tcInstFun we still have access to the function, so we+can check if it is a HsUnboundVar. We use this info to simply skip+over any visible type arguments. We've already inferred the type of+the function (in tcInferAppHead), so we'll /already/ have emitted a+Hole constraint; failing preserves that constraint.++We do /not/ want to fail altogether in this case (via failM) becuase+that may abandon an entire instance decl, which (in the presence of+-fdefer-type-errors) leads to leading to #17792.++Downside; the typechecked term has lost its visible type arguments; we+don't even kind-check them. But let's jump that bridge if we come to+it. Meanwhile, let's not crash!+++Note [Visible type application zonk]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* Substitutions should be kind-preserving, so we need kind(tv) = kind(ty_arg).++* tcHsTypeApp only guarantees that+ - ty_arg is zonked+ - kind(zonk(tv)) = kind(ty_arg)+ (checkExpectedKind zonks as it goes).++So we must zonk inner_ty as well, to guarantee consistency between zonk(tv)+and inner_ty. Otherwise we can build an ill-kinded type. An example was+#14158, where we had:+ id :: forall k. forall (cat :: k -> k -> *). forall (a :: k). cat a a+and we had the visible type application+ id @(->)++* We instantiated k := kappa, yielding+ forall (cat :: kappa -> kappa -> *). forall (a :: kappa). cat a a+* Then we called tcHsTypeApp (->) with expected kind (kappa -> kappa -> *).+* That instantiated (->) as ((->) q1 q1), and unified kappa := q1,+ Here q1 :: RuntimeRep+* Now we substitute+ cat :-> (->) q1 q1 :: TYPE q1 -> TYPE q1 -> *+ but we must first zonk the inner_ty to get+ forall (a :: TYPE q1). cat a a+ so that the result of substitution is well-kinded+ Failing to do so led to #14158.++-}++{- *********************************************************************+* *+ Quick Look+* *+********************************************************************* -}++{- Note [Quick Look at value arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The function quickLookArg implements the "QL argument" judgement of+the QL paper, in Fig 5 of "A quick look at impredicativity" (ICFP 2020),+rather directly.++Wrinkles:++* We avoid zonking, so quickLookArg thereby sees the argument type /before/+ the QL substitution Theta is applied to it. So we achieve argument-order+ independence for free (see 5.7 in the paper).++* When we quick-look at an argument, we save the work done, by returning+ an EValArg with a ValArgQL inside it. (It started life with a ValArg+ inside.) The ValArgQL remembers all the work that QL did (notably,+ decomposing the argument and instantiating) so that tcValArgs does+ not need to repeat it. Rather neat, and remarkably easy.+-}++----------------+quickLookArg :: Delta+ -> LHsExpr GhcRn -- Argument+ -> Scaled TcSigmaType -- Type expected by the function+ -> TcM (Delta, EValArg 'TcpInst)+-- See Note [Quick Look at value arguments]+--+-- The returned Delta is a superset of the one passed in+-- with added instantiation variables from+-- (a) the call itself+-- (b) the arguments of the call+quickLookArg delta larg (Scaled _ arg_ty)+ | isEmptyVarSet delta = skipQuickLook delta larg+ | otherwise = go arg_ty+ where+ guarded = isGuardedTy arg_ty+ -- NB: guardedness is computed based on the original,+ -- unzonked arg_ty, so we deliberately do not exploit+ -- guardedness that emerges a result of QL on earlier args++ go arg_ty | not (isRhoTy arg_ty)+ = skipQuickLook delta larg++ -- This top-level zonk step, which is the reason+ -- we need a local 'go' loop, is subtle+ -- See Section 9 of the QL paper+ | Just kappa <- tcGetTyVar_maybe arg_ty+ , kappa `elemVarSet` delta+ = do { info <- readMetaTyVar kappa+ ; case info of+ Indirect arg_ty' -> go arg_ty'+ Flexi -> quickLookArg1 guarded delta larg arg_ty }++ | otherwise+ = quickLookArg1 guarded delta larg arg_ty++isGuardedTy :: TcType -> Bool+isGuardedTy ty+ | Just (tc,_) <- tcSplitTyConApp_maybe ty = isGenerativeTyCon tc Nominal+ | Just {} <- tcSplitAppTy_maybe ty = True+ | otherwise = False++quickLookArg1 :: Bool -> Delta -> LHsExpr GhcRn -> TcSigmaType+ -> TcM (Delta, EValArg 'TcpInst)+quickLookArg1 guarded delta larg@(L loc arg) arg_ty+ = setSrcSpan loc $+ do { let (rn_fun,rn_args,rebuild) = splitHsApps arg+ ; mb_fun_ty <- tcInferAppHead_maybe rn_fun rn_args (Just arg_ty)+ ; traceTc "quickLookArg 1" $+ vcat [ text "arg:" <+> ppr arg+ , text "head:" <+> ppr rn_fun <+> dcolon <+> ppr mb_fun_ty+ , text "args:" <+> ppr rn_args ]++ ; case mb_fun_ty of {+ Nothing -> -- fun is too complicated+ skipQuickLook delta larg ;+ Just (fun', fun_sigma) ->++ do { let no_free_kappas = findNoQuantVars fun_sigma rn_args+ ; traceTc "quickLookArg 2" $+ vcat [ text "no_free_kappas:" <+> ppr no_free_kappas+ , text "guarded:" <+> ppr guarded ]+ ; if not (guarded || no_free_kappas)+ then skipQuickLook delta larg+ else+ do { do_ql <- wantQuickLook rn_fun+ ; (delta_app, inst_args, app_res_rho)+ <- tcInstFun do_ql True rn_fun fun_sigma rn_args+ ; traceTc "quickLookArg" $+ vcat [ text "arg:" <+> ppr arg+ , text "delta:" <+> ppr delta+ , text "delta_app:" <+> ppr delta_app+ , text "arg_ty:" <+> ppr arg_ty+ , text "app_res_rho:" <+> ppr app_res_rho ]++ -- Do quick-look unification+ -- NB: arg_ty may not be zonked, but that's ok+ ; let delta' = delta `unionVarSet` delta_app+ ; qlUnify delta' arg_ty app_res_rho++ ; let ql_arg = ValArgQL { va_expr = larg, va_fun = fun'+ , va_args = inst_args+ , va_ty = app_res_rho+ , va_rebuild = rebuild }+ ; return (delta', ql_arg) } } } }++skipQuickLook :: Delta -> LHsExpr GhcRn -> TcM (Delta, EValArg 'TcpInst)+skipQuickLook delta larg = return (delta, ValArg larg)++----------------+quickLookResultType :: Bool -> Delta -> TcRhoType -> ExpRhoType -> TcM ()+-- This function implements the shaded bit of rule APP-Downarrow in+-- Fig 5 of the QL paper: "A quick look at impredicativity" (ICFP'20).++quickLookResultType do_ql delta app_res_rho exp_res_ty+ | do_ql+ , not (isEmptyVarSet delta) -- Optimisation only+ , Just exp_rho <- checkingExpType_maybe exp_res_ty+ -- In checking mode only+ = qlUnify delta app_res_rho exp_rho+ | otherwise+ = return ()++---------------------+qlUnify :: Delta -> TcType -> TcType -> TcM ()+-- Unify ty1 with ty2, unifying only variables in delta+qlUnify delta ty1 ty2+ = do { traceTc "qlUnify" (ppr delta $$ ppr ty1 $$ ppr ty2)+ ; go (emptyVarSet,emptyVarSet) ty1 ty2 }+ where+ go :: (TyVarSet, TcTyVarSet)+ -> TcType -> TcType+ -> TcM ()+ -- The TyVarSets give the variables bound by enclosing foralls+ -- for the corresponding type. Don't unify with these.+ go bvs (TyVarTy tv) ty2+ | tv `elemVarSet` delta = go_kappa bvs tv ty2++ go (bvs1, bvs2) ty1 (TyVarTy tv)+ | tv `elemVarSet` delta = go_kappa (bvs2,bvs1) tv ty1++ go bvs (CastTy ty1 _) ty2 = go bvs ty1 ty2+ go bvs ty1 (CastTy ty2 _) = go bvs ty1 ty2++ go _ (TyConApp tc1 []) (TyConApp tc2 [])+ | tc1 == tc2 -- See GHC.Tc.Utils.Unify+ = return () -- Note [Expanding synonyms during unification]++ -- Now, and only now, expand synonyms+ go bvs rho1 rho2+ | Just rho1 <- tcView rho1 = go bvs rho1 rho2+ | Just rho2 <- tcView rho2 = go bvs rho1 rho2++ go bvs (TyConApp tc1 tys1) (TyConApp tc2 tys2)+ | tc1 == tc2+ , not (isTypeFamilyTyCon tc1)+ , tys1 `equalLength` tys2+ = zipWithM_ (go bvs) tys1 tys2++ -- Decompose (arg1 -> res1) ~ (arg2 -> res2)+ -- and (c1 => res1) ~ (c2 => res2)+ -- But for the latter we only learn instantiation info from t1~t2+ -- We look at the multiplicity too, although the chances of getting+ -- impredicative instantiation info from there seems...remote.+ go bvs (FunTy { ft_af = af1, ft_arg = arg1, ft_res = res1, ft_mult = mult1 })+ (FunTy { ft_af = af2, ft_arg = arg2, ft_res = res2, ft_mult = mult2 })+ | af1 == af2+ = do { when (af1 == VisArg) $+ do { go bvs arg1 arg2; go bvs mult1 mult2 }+ ; go bvs res1 res2 }++ -- ToDo: c.f. Tc.Utils.unify.uType,+ -- which does not split FunTy here+ -- Also NB tcRepSplitAppTy here, which does not split (c => t)+ go bvs (AppTy t1a t1b) ty2+ | Just (t2a, t2b) <- tcRepSplitAppTy_maybe ty2+ = do { go bvs t1a t2a; go bvs t1b t2b }++ go bvs ty1 (AppTy t2a t2b)+ | Just (t1a, t1b) <- tcRepSplitAppTy_maybe ty1+ = do { go bvs t1a t2a; go bvs t1b t2b }++ go (bvs1, bvs2) (ForAllTy bv1 ty1) (ForAllTy bv2 ty2)+ = go (bvs1',bvs2') ty1 ty2+ where+ bvs1' = bvs1 `extendVarSet` binderVar bv1+ bvs2' = bvs2 `extendVarSet` binderVar bv2++ go _ _ _ = return ()+++ ----------------+ go_kappa bvs kappa ty2+ = ASSERT2( isMetaTyVar kappa, ppr kappa )+ do { info <- readMetaTyVar kappa+ ; case info of+ Indirect ty1 -> go bvs ty1 ty2+ Flexi -> do { ty2 <- zonkTcType ty2+ ; go_flexi bvs kappa ty2 } }++ ----------------+ go_flexi (_,bvs2) kappa ty2 -- ty2 is zonked+ | -- See Note [Actual unification in qlUnify]+ let ty2_tvs = shallowTyCoVarsOfType ty2+ , not (ty2_tvs `intersectsVarSet` bvs2)+ -- Can't instantiate a delta-varto a forall-bound variable+ , Just ty2 <- occCheckExpand [kappa] ty2+ -- Passes the occurs check+ = do { let ty2_kind = typeKind ty2+ kappa_kind = tyVarKind kappa+ ; co <- unifyKind (Just (ppr ty2)) ty2_kind kappa_kind+ -- unifyKind: see Note [Actual unification in qlUnify]++ ; traceTc "qlUnify:update" $+ vcat [ hang (ppr kappa <+> dcolon <+> ppr kappa_kind)+ 2 (text ":=" <+> ppr ty2 <+> dcolon <+> ppr ty2_kind)+ , text "co:" <+> ppr co ]+ ; writeMetaTyVar kappa (mkCastTy ty2 co) }++ | otherwise+ = return () -- Occurs-check or forall-bound varialbe+++{- Note [Actual unification in qlUnify]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In qlUnify, if we find (kappa ~ ty), we are going to update kappa := ty.+That is the entire point of qlUnify! Wrinkles:++* We must not unify with anything bound by an enclosing forall; e.g.+ (forall a. kappa -> Int) ~ forall a. a -> Int)+ That's tracked by the 'bvs' arg of 'go'.++* We must not make an occurs-check; we use occCheckExpand for that.++* metaTyVarUpdateOK also checks for various other things, including+ - foralls, and predicate types (which we want to allow here)+ - type families (relates to a very specific and exotic performance+ question, that is unlikely to bite here)+ - blocking coercion holes+ After some thought we believe that none of these are relevant+ here++* What if kappa and ty have different kinds? We solve that problem by+ calling unifyKind, producing a coercion perhaps emitting some deferred+ equality constraints. That is /different/ from the approach we use in+ the main constraint solver for herterogeneous equalities; see Note+ [Equalities with incompatible kinds] in Solver.Canonical++ Why different? Because:+ - We can't use qlUnify to solve the kind constraint because qlUnify+ won't unify ordinary (non-instantiation) unification variables.+ (It would have to worry about lots of things like untouchability+ if it did.)+ - qlUnify can't give up if the kinds look un-equal because that would+ mean that it might succeed some times (when the eager unifier+ has already unified those kinds) but not others -- order+ dependence.+ - We can't use the ordinary unifier/constraint solver instead,+ because it doesn't unify polykinds, and has all kinds of other+ magic. qlUnify is very focused.++ TL;DR Calling unifyKind seems like the lesser evil.+ -}++{- *********************************************************************+* *+ Guardedness+* *+********************************************************************* -}++findNoQuantVars :: TcSigmaType -> [HsExprArg 'TcpRn] -> Bool+-- True <=> there are no free quantified variables+-- in the result of the call+-- E.g. in the call (f e1 e2), if+-- f :: forall a b. a -> b -> Int return True+-- f :: forall a b. a -> b -> b return False (b is free)+findNoQuantVars fun_ty args+ = go emptyVarSet fun_ty args+ where+ need_instantiation [] = True+ need_instantiation (EValArg {} : _) = True+ need_instantiation _ = False++ go :: TyVarSet -> TcSigmaType -> [HsExprArg 'TcpRn] -> Bool+ go bvs fun_ty args+ | need_instantiation args+ , (tvs, theta, rho) <- tcSplitSigmaTy fun_ty+ , not (null tvs && null theta)+ = go (bvs `extendVarSetList` tvs) rho args++ go bvs fun_ty [] = tyCoVarsOfType fun_ty `disjointVarSet` bvs++ go bvs fun_ty (EPar {} : args) = go bvs fun_ty args+ go bvs fun_ty (EPrag {} : args) = go bvs fun_ty args++ go bvs fun_ty args@(ETypeArg {} : rest_args)+ | (tvs, body1) <- tcSplitSomeForAllTys (== Inferred) fun_ty+ , (theta, body2) <- tcSplitPhiTy body1+ , not (null tvs && null theta)+ = go (bvs `extendVarSetList` tvs) body2 args+ | Just (_tv, res_ty) <- tcSplitForAllTy_maybe fun_ty+ = go bvs res_ty rest_args+ | otherwise+ = False -- E.g. head ids @Int++ go bvs fun_ty (EValArg {} : rest_args)+ | Just (_, res_ty) <- tcSplitFunTy_maybe fun_ty+ = go bvs res_ty rest_args+ | otherwise+ = False -- E.g. head id 'x'+++{- *********************************************************************+* *+ tagToEnum#+* *+********************************************************************* -}++{- Note [tagToEnum#]+~~~~~~~~~~~~~~~~~~~~+Nasty check to ensure that tagToEnum# is applied to a type that is an+enumeration TyCon. Unification may refine the type later, but this+check won't see that, alas. It's crude, because it relies on our+knowing *now* that the type is ok, which in turn relies on the+eager-unification part of the type checker pushing enough information+here. In theory the Right Thing to do is to have a new form of+constraint but I definitely cannot face that! And it works ok as-is.++Here's are two cases that should fail+ f :: forall a. a+ f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable++ g :: Int+ g = tagToEnum# 0 -- Int is not an enumeration++When data type families are involved it's a bit more complicated.+ data family F a+ data instance F [Int] = A | B | C+Then we want to generate something like+ tagToEnum# R:FListInt 3# |> co :: R:FListInt ~ F [Int]+Usually that coercion is hidden inside the wrappers for+constructors of F [Int] but here we have to do it explicitly.++It's all grotesquely complicated.+-}++isTagToEnum :: HsExpr GhcRn -> Bool+isTagToEnum (HsVar _ (L _ fun_id)) = fun_id `hasKey` tagToEnumKey+isTagToEnum _ = False++tcTagToEnum :: HsExpr GhcRn -> HsExpr GhcTc -> [HsExprArg 'TcpTc]+ -> TcRhoType -> ExpRhoType+ -> TcM (HsExpr GhcTc)+-- tagToEnum# :: forall a. Int# -> a+-- See Note [tagToEnum#] Urgh!+tcTagToEnum expr fun args app_res_ty res_ty+ | null val_args+ = failWithTc (text "tagToEnum# must appear applied to one argument")++ | otherwise+ = do { res_ty <- readExpType res_ty+ ; ty' <- zonkTcType res_ty++ -- Check that the type is algebraic+ ; case tcSplitTyConApp_maybe ty' of {+ Nothing -> do { addErrTc (mk_error ty' doc1)+ ; vanilla_result } ;+ Just (tc, tc_args) ->++ do { -- Look through any type family+ ; fam_envs <- tcGetFamInstEnvs+ ; case tcLookupDataFamInst_maybe fam_envs tc tc_args of {+ Nothing -> do { check_enumeration ty' tc+ ; vanilla_result } ;+ Just (rep_tc, rep_args, coi) ->++ do { -- coi :: tc tc_args ~R rep_tc rep_args+ check_enumeration ty' rep_tc+ ; let rep_ty = mkTyConApp rep_tc rep_args+ fun' = mkHsWrap (WpTyApp rep_ty) fun+ expr' = rebuildPrefixApps fun' val_args+ df_wrap = mkWpCastR (mkTcSymCo coi)+ ; return (mkHsWrap df_wrap expr') }}}}}++ where+ val_args = dropWhile (not . isHsValArg) args++ vanilla_result+ = do { let expr' = rebuildPrefixApps fun args+ ; tcWrapResult expr expr' app_res_ty res_ty }++ check_enumeration ty' tc+ | isEnumerationTyCon tc = return ()+ | otherwise = addErrTc (mk_error ty' doc2)++ doc1 = vcat [ text "Specify the type by giving a type signature"+ , text "e.g. (tagToEnum# x) :: Bool" ]+ doc2 = text "Result type must be an enumeration type"++ mk_error :: TcType -> SDoc -> SDoc+ mk_error ty what+ = hang (text "Bad call to tagToEnum#"+ <+> text "at type" <+> ppr ty)+ 2 what+++{- *********************************************************************+* *+ Pragmas on expressions+* *+********************************************************************* -}++tcExprPrag :: HsPragE GhcRn -> HsPragE GhcTc+tcExprPrag (HsPragSCC x1 src ann) = HsPragSCC x1 src ann++
compiler/GHC/Tc/Gen/Arrow.hs view
@@ -15,10 +15,11 @@ import GHC.Prelude import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcCheckMonoExpr, tcInferRho, tcSyntaxOp- , tcCheckId, tcCheckPolyExpr )+ , tcCheckPolyExpr ) import GHC.Hs import GHC.Tc.Gen.Match+import GHC.Tc.Gen.Head( tcCheckId ) import GHC.Tc.Utils.Zonk( hsLPatType ) import GHC.Tc.Utils.TcType import GHC.Tc.Utils.TcMType
compiler/GHC/Tc/Gen/Bind.hs view
@@ -44,9 +44,8 @@ import GHC.Core.Multiplicity import GHC.Core.FamInstEnv( normaliseType ) import GHC.Tc.Instance.Family( tcGetFamInstEnvs )-import GHC.Core.TyCon import GHC.Tc.Utils.TcType-import GHC.Core.Type (mkStrLitTy, tidyOpenType, splitTyConApp_maybe, mkCastTy)+import GHC.Core.Type (mkStrLitTy, tidyOpenType, mkCastTy) import GHC.Builtin.Types.Prim import GHC.Builtin.Types( mkBoxedTupleTy ) import GHC.Types.Id@@ -69,9 +68,9 @@ import GHC.Builtin.Names( ipClassName ) import GHC.Tc.Validity (checkValidType) import GHC.Types.Unique.FM+import GHC.Types.Unique.DSet import GHC.Types.Unique.Set import qualified GHC.LanguageExtensions as LangExt-import GHC.Core.ConLike import Control.Monad import Data.Foldable (find)@@ -197,112 +196,22 @@ -- The top level bindings are flattened into a giant -- implicitly-mutually-recursive LHsBinds ---- Note [Typechecking Complete Matches]--- Much like when a user bundled a pattern synonym, the result types of--- all the constructors in the match pragma must be consistent.------ If we allowed pragmas with inconsistent types then it would be--- impossible to ever match every constructor in the list and so--- the pragma would be useless.-------- This is only used in `tcCompleteSig`. We fold over all the conlikes,--- this accumulator keeps track of the first `ConLike` with a concrete--- return type. After fixing the return type, all other constructors with--- a fixed return type must agree with this.------ The fields of `Fixed` cache the first conlike and its return type so--- that we can compare all the other conlikes to it. The conlike is--- stored for error messages.------ `Nothing` in the case that the type is fixed by a type signature-data CompleteSigType = AcceptAny | Fixed (Maybe ConLike) TyCon- tcCompleteSigs :: [LSig GhcRn] -> TcM [CompleteMatch] tcCompleteSigs sigs = let- doOne :: Sig GhcRn -> TcM (Maybe CompleteMatch)- doOne c@(CompleteMatchSig _ _ lns mtc)- = fmap Just $ do- addErrCtxt (text "In" <+> ppr c) $- case mtc of- Nothing -> infer_complete_match- Just tc -> check_complete_match tc- where-- checkCLTypes acc = foldM checkCLType (acc, []) (unLoc lns)-- infer_complete_match = do- (res, cls) <- checkCLTypes AcceptAny- case res of- AcceptAny -> failWithTc ambiguousError- Fixed _ tc -> return $ mkMatch cls tc-- check_complete_match tc_name = do- ty_con <- tcLookupLocatedTyCon tc_name- (_, cls) <- checkCLTypes (Fixed Nothing ty_con)- return $ mkMatch cls ty_con-- mkMatch :: [ConLike] -> TyCon -> CompleteMatch- mkMatch cls ty_con = CompleteMatch {- -- foldM is a left-fold and will have accumulated the ConLikes in- -- the reverse order. foldrM would accumulate in the correct order,- -- but would type-check the last ConLike first, which might also be- -- confusing from the user's perspective. Hence reverse here.- completeMatchConLikes = reverse (map conLikeName cls),- completeMatchTyCon = tyConName ty_con- }+ doOne :: LSig GhcRn -> TcM (Maybe CompleteMatch)+ -- We don't need to "type-check" COMPLETE signatures anymore; if their+ -- combinations are invalid it will be found so at match sites. Hence we+ -- keep '_mtc' only for backwards compatibility.+ doOne (L loc c@(CompleteMatchSig _ext _src_txt (L _ ns) _mtc))+ = fmap Just $ setSrcSpan loc $ addErrCtxt (text "In" <+> ppr c) $+ mkUniqDSet <$> mapM (addLocM tcLookupConLike) ns doOne _ = return Nothing - ambiguousError :: SDoc- ambiguousError =- text "A type signature must be provided for a set of polymorphic"- <+> text "pattern synonyms."--- -- See note [Typechecking Complete Matches]- checkCLType :: (CompleteSigType, [ConLike]) -> Located Name- -> TcM (CompleteSigType, [ConLike])- checkCLType (cst, cs) n = do- cl <- addLocM tcLookupConLike n- let (_,_,_,_,_,_, res_ty) = conLikeFullSig cl- res_ty_con = fst <$> splitTyConApp_maybe res_ty- case (cst, res_ty_con) of- (AcceptAny, Nothing) -> return (AcceptAny, cl:cs)- (AcceptAny, Just tc) -> return (Fixed (Just cl) tc, cl:cs)- (Fixed mfcl tc, Nothing) -> return (Fixed mfcl tc, cl:cs)- (Fixed mfcl tc, Just tc') ->- if tc == tc'- then return (Fixed mfcl tc, cl:cs)- else case mfcl of- Nothing ->- addErrCtxt (text "In" <+> ppr cl) $- failWithTc typeSigErrMsg- Just cl -> failWithTc (errMsg cl)- where- typeSigErrMsg :: SDoc- typeSigErrMsg =- text "Couldn't match expected type"- <+> quotes (ppr tc)- <+> text "with"- <+> quotes (ppr tc')-- errMsg :: ConLike -> SDoc- errMsg fcl =- text "Cannot form a group of complete patterns from patterns"- <+> quotes (ppr fcl) <+> text "and" <+> quotes (ppr cl)- <+> text "as they match different type constructors"- <+> parens (quotes (ppr tc)- <+> text "resp."- <+> quotes (ppr tc')) -- For some reason I haven't investigated further, the signatures come in -- backwards wrt. declaration order. So we reverse them here, because it makes -- a difference for incomplete match suggestions.- in mapMaybeM (addLocM doOne) (reverse sigs) -- process in declaration order+ in mapMaybeM doOne $ reverse sigs tcHsBootSigs :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [Id] -- A hs-boot file has only one BindGroup, and it only has type@@ -772,7 +681,7 @@ = getOccFS (Var.varName fun_id) cc_name = moduleNameFS (moduleName mod) `appendFS` consFS '.' cc_str = do- flavour <- DeclCC <$> getCCIndexM cc_name+ flavour <- DeclCC <$> getCCIndexTcM cc_name let cc = mkUserCC cc_name mod loc flavour return [ProfNote cc True True] | otherwise
compiler/GHC/Tc/Gen/Default.hs view
@@ -71,7 +71,7 @@ tc_default_ty :: [Class] -> LHsType GhcRn -> TcM Type tc_default_ty deflt_clss hs_ty- = do { ty <- solveEqualities $+ = do { ty <- solveEqualities "tc_default_ty" $ tcInferLHsType hs_ty ; ty <- zonkTcTypeToType ty -- establish Type invariants ; checkValidType DefaultDeclCtxt ty
compiler/GHC/Tc/Gen/Expr.hs view
@@ -14,2913 +14,1648 @@ {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module GHC.Tc.Gen.Expr- ( tcCheckPolyExpr,- tcCheckMonoExpr, tcCheckMonoExprNC, tcMonoExpr, tcMonoExprNC,- tcInferSigma, tcInferRho, tcInferRhoNC,- tcExpr,- tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType,- tcCheckId,- addAmbiguousNameErr,- getFixedTyVars ) where--#include "GhclibHsVersions.h"--import GHC.Prelude--import {-# SOURCE #-} GHC.Tc.Gen.Splice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket )-import GHC.Builtin.Names.TH( liftStringName, liftName )--import GHC.Hs-import GHC.Tc.Utils.Zonk-import GHC.Tc.Utils.Monad-import GHC.Tc.Utils.Unify-import GHC.Types.Basic-import GHC.Core.Multiplicity-import GHC.Core.UsageEnv-import GHC.Tc.Utils.Instantiate-import GHC.Tc.Gen.Bind ( chooseInferredQuantifiers, tcLocalBinds )-import GHC.Tc.Gen.Sig ( tcUserTypeSig, tcInstSig )-import GHC.Tc.Solver ( simplifyInfer, InferMode(..) )-import GHC.Tc.Instance.Family ( tcGetFamInstEnvs, tcLookupDataFamInst, tcLookupDataFamInst_maybe )-import GHC.Core.FamInstEnv ( FamInstEnvs )-import GHC.Rename.Env ( addUsedGRE )-import GHC.Rename.Utils ( addNameClashErrRn, unknownSubordinateErr )-import GHC.Tc.Utils.Env-import GHC.Tc.Gen.Arrow-import GHC.Tc.Gen.Match-import GHC.Tc.Gen.HsType-import GHC.Tc.TyCl.PatSyn ( tcPatSynBuilderOcc, nonBidirectionalErr )-import GHC.Tc.Gen.Pat-import GHC.Tc.Utils.TcMType-import GHC.Tc.Types.Origin-import GHC.Tc.Utils.TcType as TcType-import GHC.Types.Id-import GHC.Types.Id.Info-import GHC.Core.ConLike-import GHC.Core.DataCon-import GHC.Core.PatSyn-import GHC.Types.Name-import GHC.Types.Name.Env-import GHC.Types.Name.Set-import GHC.Types.Name.Reader-import GHC.Core.TyCon-import GHC.Core.TyCo.Rep-import GHC.Core.TyCo.Ppr-import GHC.Core.TyCo.Subst (substTyWithInScope)-import GHC.Core.Type-import GHC.Tc.Types.Evidence-import GHC.Types.Var.Set-import GHC.Builtin.Types-import GHC.Builtin.PrimOps( tagToEnumKey )-import GHC.Builtin.Names-import GHC.Driver.Session-import GHC.Types.SrcLoc-import GHC.Utils.Misc-import GHC.Types.Var.Env ( emptyTidyEnv, mkInScopeSet )-import GHC.Data.List.SetOps-import GHC.Data.Maybe-import GHC.Utils.Outputable as Outputable-import GHC.Utils.Panic-import GHC.Data.FastString-import Control.Monad-import GHC.Core.Class(classTyCon)-import GHC.Types.Unique.Set ( nonDetEltsUniqSet )-import qualified GHC.LanguageExtensions as LangExt--import Data.Function-import Data.List (partition, sortBy, groupBy, intersect)-import qualified Data.Set as Set--{--************************************************************************-* *-\subsection{Main wrappers}-* *-************************************************************************--}---tcCheckPolyExpr, tcCheckPolyExprNC- :: LHsExpr GhcRn -- Expression to type check- -> TcSigmaType -- Expected type (could be a polytype)- -> TcM (LHsExpr GhcTc) -- Generalised expr with expected type---- tcCheckPolyExpr is a convenient place (frequent but not too frequent)--- place to add context information.--- The NC version does not do so, usually because the caller wants--- to do so himself.--tcCheckPolyExpr expr res_ty = tcPolyExpr expr (mkCheckExpType res_ty)-tcCheckPolyExprNC expr res_ty = tcPolyExprNC expr (mkCheckExpType res_ty)---- These versions take an ExpType-tcPolyExpr, tcPolyExprNC- :: LHsExpr GhcRn -> ExpSigmaType- -> TcM (LHsExpr GhcTc)--tcPolyExpr expr res_ty- = addExprCtxt expr $- do { traceTc "tcPolyExpr" (ppr res_ty)- ; tcPolyExprNC expr res_ty }--tcPolyExprNC (L loc expr) res_ty- = set_loc_and_ctxt loc expr $- do { traceTc "tcPolyExprNC" (ppr res_ty)- ; (wrap, expr') <- tcSkolemiseET GenSigCtxt res_ty $ \ res_ty ->- tcExpr expr res_ty- ; return $ L loc (mkHsWrap wrap expr') }-- where -- See Note [Rebindable syntax and HsExpansion), which describes- -- the logic behind this location/context tweaking.- set_loc_and_ctxt l e m = do- inGenCode <- inGeneratedCode- if inGenCode && not (isGeneratedSrcSpan l)- then setSrcSpan l $ addExprCtxt (L l e) m- else setSrcSpan l m------------------tcInferSigma :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcSigmaType)--- Used by tcRnExpr to implement GHCi :type--- It goes against the principle of eager instantiation,--- so we expect very very few calls to this function--- Most clients will want tcInferRho-tcInferSigma le@(L loc expr)- = addExprCtxt le $ setSrcSpan loc $- do { (fun, args, ty) <- tcInferApp expr- ; return (L loc (applyHsArgs fun args), ty) }------------------tcCheckMonoExpr, tcCheckMonoExprNC- :: LHsExpr GhcRn -- Expression to type check- -> TcRhoType -- Expected type- -- Definitely no foralls at the top- -> TcM (LHsExpr GhcTc)-tcCheckMonoExpr expr res_ty = tcMonoExpr expr (mkCheckExpType res_ty)-tcCheckMonoExprNC expr res_ty = tcMonoExprNC expr (mkCheckExpType res_ty)--tcMonoExpr, tcMonoExprNC- :: LHsExpr GhcRn -- Expression to type check- -> ExpRhoType -- Expected type- -- Definitely no foralls at the top- -> TcM (LHsExpr GhcTc)--tcMonoExpr expr res_ty- = addExprCtxt expr $- tcMonoExprNC expr res_ty--tcMonoExprNC (L loc expr) res_ty- = setSrcSpan loc $- do { expr' <- tcExpr expr res_ty- ; return (L loc expr') }------------------tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType)--- Infer a *rho*-type. The return type is always instantiated.-tcInferRho le = addExprCtxt le (tcInferRhoNC le)--tcInferRhoNC (L loc expr)- = setSrcSpan loc $- do { (expr', rho) <- tcInfer (tcExpr expr)- ; return (L loc expr', rho) }---{- *********************************************************************-* *- tcExpr: the main expression typechecker-* *-********************************************************************* -}--tcLExpr, tcLExprNC- :: LHsExpr GhcRn -- Expression to type check- -> ExpRhoType -- Expected type- -- Definitely no foralls at the top- -> TcM (LHsExpr GhcTc)--tcLExpr expr res_ty- = setSrcSpan (getLoc expr) $ addExprCtxt expr (tcLExprNC expr res_ty)--tcLExprNC (L loc expr) res_ty- = setSrcSpan loc $- do { expr' <- tcExpr expr res_ty- ; return (L loc expr') }--tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)-tcExpr (HsVar _ (L _ name)) res_ty = tcCheckId name res_ty-tcExpr e@(HsUnboundVar _ uv) res_ty = tcUnboundId e uv res_ty--tcExpr e@(HsApp {}) res_ty = tcApp e res_ty-tcExpr e@(HsAppType {}) res_ty = tcApp e res_ty--tcExpr e@(HsLit x lit) res_ty- = do { let lit_ty = hsLitType lit- ; tcWrapResult e (HsLit x (convertLit lit)) lit_ty res_ty }--tcExpr (HsPar x expr) res_ty = do { expr' <- tcLExprNC expr res_ty- ; return (HsPar x expr') }--tcExpr (HsPragE x prag expr) res_ty- = do { expr' <- tcLExpr expr res_ty- ; return (HsPragE x (tcExprPrag prag) expr') }--tcExpr (HsOverLit x lit) res_ty- = do { lit' <- newOverloadedLit lit res_ty- ; return (HsOverLit x lit') }--tcExpr (NegApp x expr neg_expr) res_ty- = do { (expr', neg_expr')- <- tcSyntaxOp NegateOrigin neg_expr [SynAny] res_ty $- \[arg_ty] [arg_mult] ->- tcScalingUsage arg_mult $ tcLExpr expr (mkCheckExpType arg_ty)- ; return (NegApp x expr' neg_expr') }--tcExpr e@(HsIPVar _ x) res_ty- = do { {- Implicit parameters must have a *tau-type* not a- type scheme. We enforce this by creating a fresh- type variable as its type. (Because res_ty may not- be a tau-type.) -}- ip_ty <- newOpenFlexiTyVarTy- ; let ip_name = mkStrLitTy (hsIPNameFS x)- ; ipClass <- tcLookupClass ipClassName- ; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty])- ; tcWrapResult e- (fromDict ipClass ip_name ip_ty (HsVar noExtField (noLoc ip_var)))- ip_ty res_ty }- where- -- Coerces a dictionary for `IP "x" t` into `t`.- fromDict ipClass x ty = mkHsWrap $ mkWpCastR $- unwrapIP $ mkClassPred ipClass [x,ty]- origin = IPOccOrigin x--tcExpr e@(HsOverLabel _ mb_fromLabel l) res_ty- = do { -- See Note [Type-checking overloaded labels]- loc <- getSrcSpanM- ; case mb_fromLabel of- Just fromLabel -> tcExpr (applyFromLabel loc fromLabel) res_ty- Nothing -> do { isLabelClass <- tcLookupClass isLabelClassName- ; alpha <- newFlexiTyVarTy liftedTypeKind- ; let pred = mkClassPred isLabelClass [lbl, alpha]- ; loc <- getSrcSpanM- ; var <- emitWantedEvVar origin pred- ; tcWrapResult e- (fromDict pred (HsVar noExtField (L loc var)))- alpha res_ty } }- where- -- Coerces a dictionary for `IsLabel "x" t` into `t`,- -- or `HasField "x" r a into `r -> a`.- fromDict pred = mkHsWrap $ mkWpCastR $ unwrapIP pred- origin = OverLabelOrigin l- lbl = mkStrLitTy l-- applyFromLabel loc fromLabel =- HsAppType noExtField- (L loc (HsVar noExtField (L loc fromLabel)))- (mkEmptyWildCardBndrs (L loc (HsTyLit noExtField (HsStrTy NoSourceText l))))--tcExpr (HsLam x match) res_ty- = do { (wrap, match') <- tcMatchLambda herald match_ctxt match res_ty- ; return (mkHsWrap wrap (HsLam x match')) }- where- match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody }- herald = sep [ text "The lambda expression" <+>- quotes (pprSetDepth (PartWay 1) $- pprMatches match),- -- The pprSetDepth makes the abstraction print briefly- text "has"]--tcExpr e@(HsLamCase x matches) res_ty- = do { (wrap, matches')- <- tcMatchLambda msg match_ctxt matches res_ty- -- The laziness annotation is because we don't want to fail here- -- if there are multiple arguments- ; return (mkHsWrap wrap $ HsLamCase x matches') }- where- msg = sep [ text "The function" <+> quotes (ppr e)- , text "requires"]- match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody }--tcExpr e@(ExprWithTySig _ expr hs_ty) res_ty- = do { (expr', poly_ty) <- tcExprWithSig expr hs_ty- ; tcWrapResult e expr' poly_ty res_ty }--{--Note [Type-checking overloaded labels]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Recall that we have-- module GHC.OverloadedLabels where- class IsLabel (x :: Symbol) a where- fromLabel :: a--We translate `#foo` to `fromLabel @"foo"`, where we use-- * the in-scope `fromLabel` if `RebindableSyntax` is enabled; or if not- * `GHC.OverloadedLabels.fromLabel`.--In the `RebindableSyntax` case, the renamer will have filled in the-first field of `HsOverLabel` with the `fromLabel` function to use, and-we simply apply it to the appropriate visible type argument.--In the `OverloadedLabels` case, when we see an overloaded label like-`#foo`, we generate a fresh variable `alpha` for the type and emit an-`IsLabel "foo" alpha` constraint. Because the `IsLabel` class has a-single method, it is represented by a newtype, so we can coerce-`IsLabel "foo" alpha` to `alpha` (just like for implicit parameters).---}---{--************************************************************************-* *- Infix operators and sections-* *-************************************************************************--Note [Left sections]-~~~~~~~~~~~~~~~~~~~~-Left sections, like (4 *), are equivalent to- \ x -> (*) 4 x,-or, if PostfixOperators is enabled, just- (*) 4-With PostfixOperators we don't actually require the function to take-two arguments at all. For example, (x `not`) means (not x); you get-postfix operators! Not Haskell 98, but it's less work and kind of-useful.--Note [Typing rule for ($)]-~~~~~~~~~~~~~~~~~~~~~~~~~~-People write- runST $ blah-so much, where- runST :: (forall s. ST s a) -> a-that I have finally given in and written a special type-checking-rule just for saturated applications of ($).- * Infer the type of the first argument- * Decompose it; should be of form (arg2_ty -> res_ty),- where arg2_ty might be a polytype- * Use arg2_ty to typecheck arg2--}--tcExpr expr@(OpApp fix arg1 op arg2) res_ty- | (L loc (HsVar _ (L lv op_name))) <- op- , op_name `hasKey` dollarIdKey -- Note [Typing rule for ($)]- = do { traceTc "Application rule" (ppr op)- ; (arg1', arg1_ty) <- addErrCtxt (funAppCtxt op arg1 1) $- tcInferRhoNC arg1-- ; let doc = text "The first argument of ($) takes"- orig1 = lexprCtOrigin arg1- ; (wrap_arg1, [arg2_sigma], op_res_ty) <-- matchActualFunTysRho doc orig1 (Just (unLoc arg1)) 1 arg1_ty-- ; mult_wrap <- tcSubMult AppOrigin Many (scaledMult arg2_sigma)- -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.- --- -- When ($) becomes multiplicity-polymorphic, then the above check will- -- need to go. But in the meantime, it would produce ill-typed- -- desugared code to accept linear functions to the left of a ($).-- -- We have (arg1 $ arg2)- -- So: arg1_ty = arg2_ty -> op_res_ty- -- where arg2_sigma maybe polymorphic; that's the point-- ; arg2' <- tcArg nl_op arg2 arg2_sigma 2-- -- Make sure that the argument type has kind '*'- -- ($) :: forall (r:RuntimeRep) (a:*) (b:TYPE r). (a->b) -> a -> b- -- Eg we do not want to allow (D# $ 4.0#) #5570- -- (which gives a seg fault)- ; _ <- unifyKind (Just (XHsType $ NHsCoreTy (scaledThing arg2_sigma)))- (tcTypeKind (scaledThing arg2_sigma)) liftedTypeKind- -- Ignore the evidence. arg2_sigma must have type * or #,- -- because we know (arg2_sigma -> op_res_ty) is well-kinded- -- (because otherwise matchActualFunTysRho would fail)- -- So this 'unifyKind' will either succeed with Refl, or will- -- produce an insoluble constraint * ~ #, which we'll report later.-- -- NB: unlike the argument type, the *result* type, op_res_ty can- -- have any kind (#8739), so we don't need to check anything for that-- ; op_id <- tcLookupId op_name- ; let op' = L loc (mkHsWrap (mkWpTyApps [ getRuntimeRep op_res_ty- , scaledThing arg2_sigma- , op_res_ty])- (HsVar noExtField (L lv op_id)))- -- arg1' :: arg1_ty- -- wrap_arg1 :: arg1_ty "->" (arg2_sigma -> op_res_ty)- -- op' :: (a2_ty -> op_res_ty) -> a2_ty -> op_res_ty-- expr' = OpApp fix (mkLHsWrap (wrap_arg1 <.> mult_wrap) arg1') op' arg2'-- ; tcWrapResult expr expr' op_res_ty res_ty }-- | L loc (HsRecFld _ (Ambiguous _ lbl)) <- op- , Just sig_ty <- obviousSig (unLoc arg1)- -- See Note [Disambiguating record fields]- = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty- ; sel_name <- disambiguateSelector lbl sig_tc_ty- ; let op' = L loc (HsRecFld noExtField (Unambiguous sel_name lbl))- ; tcExpr (OpApp fix arg1 op' arg2) res_ty- }-- | otherwise- = do { traceTc "Non Application rule" (ppr op)- ; (op', op_ty) <- tcInferRhoNC op-- ; (wrap_fun, [arg1_ty, arg2_ty], op_res_ty)- <- matchActualFunTysRho (mk_op_msg op) fn_orig- (Just (unLoc op)) 2 op_ty- -- You might think we should use tcInferApp here, but there is- -- too much impedance-matching, because tcApp may return wrappers as- -- well as type-checked arguments.-- ; arg1' <- tcArg nl_op arg1 arg1_ty 1- ; arg2' <- tcArg nl_op arg2 arg2_ty 2-- ; let expr' = OpApp fix arg1' (mkLHsWrap wrap_fun op') arg2'- ; tcWrapResult expr expr' op_res_ty res_ty }- where- fn_orig = exprCtOrigin nl_op- nl_op = unLoc op---- Right sections, equivalent to \ x -> x `op` expr, or--- \ x -> op x expr--tcExpr expr@(SectionR x op arg2) res_ty- = do { (op', op_ty) <- tcInferRhoNC op- ; (wrap_fun, [Scaled arg1_mult arg1_ty, arg2_ty], op_res_ty)- <- matchActualFunTysRho (mk_op_msg op) fn_orig- (Just (unLoc op)) 2 op_ty- ; arg2' <- tcArg (unLoc op) arg2 arg2_ty 2- ; let expr' = SectionR x (mkLHsWrap wrap_fun op') arg2'- act_res_ty = mkVisFunTy arg1_mult arg1_ty op_res_ty- ; tcWrapResultMono expr expr' act_res_ty res_ty }-- where- fn_orig = lexprCtOrigin op- -- It's important to use the origin of 'op', so that call-stacks- -- come out right; they are driven by the OccurrenceOf CtOrigin- -- See #13285--tcExpr expr@(SectionL x arg1 op) res_ty- = do { (op', op_ty) <- tcInferRhoNC op- ; dflags <- getDynFlags -- Note [Left sections]- ; let n_reqd_args | xopt LangExt.PostfixOperators dflags = 1- | otherwise = 2-- ; (wrap_fn, (arg1_ty:arg_tys), op_res_ty)- <- matchActualFunTysRho (mk_op_msg op) fn_orig- (Just (unLoc op)) n_reqd_args op_ty- ; arg1' <- tcArg (unLoc op) arg1 arg1_ty 1- ; let expr' = SectionL x arg1' (mkLHsWrap wrap_fn op')- act_res_ty = mkVisFunTys arg_tys op_res_ty- ; tcWrapResultMono expr expr' act_res_ty res_ty }- where- fn_orig = lexprCtOrigin op- -- It's important to use the origin of 'op', so that call-stacks- -- come out right; they are driven by the OccurrenceOf CtOrigin- -- See #13285--tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty- | all tupArgPresent tup_args- = do { let arity = length tup_args- tup_tc = tupleTyCon boxity arity- -- NB: tupleTyCon doesn't flatten 1-tuples- -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make- ; res_ty <- expTypeToType res_ty- ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty- -- Unboxed tuples have RuntimeRep vars, which we- -- don't care about here- -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon- ; let arg_tys' = case boxity of Unboxed -> drop arity arg_tys- Boxed -> arg_tys- ; tup_args1 <- tcTupArgs tup_args arg_tys'- ; return $ mkHsWrapCo coi (ExplicitTuple x tup_args1 boxity) }-- | otherwise- = -- The tup_args are a mixture of Present and Missing (for tuple sections)- do { let arity = length tup_args-- ; arg_tys <- case boxity of- { Boxed -> newFlexiTyVarTys arity liftedTypeKind- ; Unboxed -> replicateM arity newOpenFlexiTyVarTy }-- -- Handle tuple sections where- ; tup_args1 <- tcTupArgs tup_args arg_tys-- ; let expr' = ExplicitTuple x tup_args1 boxity- missing_tys = [Scaled mult ty | (L _ (Missing (Scaled mult _)), ty) <- zip tup_args1 arg_tys]-- -- See Note [Linear fields generalization]- act_res_ty- = mkVisFunTys missing_tys (mkTupleTy1 boxity arg_tys)- -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make-- ; traceTc "ExplicitTuple" (ppr act_res_ty $$ ppr res_ty)-- ; tcWrapResultMono expr expr' act_res_ty res_ty }--tcExpr (ExplicitSum _ alt arity expr) res_ty- = do { let sum_tc = sumTyCon arity- ; res_ty <- expTypeToType res_ty- ; (coi, arg_tys) <- matchExpectedTyConApp sum_tc res_ty- ; -- Drop levity vars, we don't care about them here- let arg_tys' = drop arity arg_tys- ; expr' <- tcCheckPolyExpr expr (arg_tys' `getNth` (alt - 1))- ; return $ mkHsWrapCo coi (ExplicitSum arg_tys' alt arity expr' ) }---- This will see the empty list only when -XOverloadedLists.--- See Note [Empty lists] in GHC.Hs.Expr.-tcExpr (ExplicitList _ witness exprs) res_ty- = case witness of- Nothing -> do { res_ty <- expTypeToType res_ty- ; (coi, elt_ty) <- matchExpectedListTy res_ty- ; exprs' <- mapM (tc_elt elt_ty) exprs- ; return $- mkHsWrapCo coi $ ExplicitList elt_ty Nothing exprs' }-- Just fln -> do { ((exprs', elt_ty), fln')- <- tcSyntaxOp ListOrigin fln- [synKnownType intTy, SynList] res_ty $- \ [elt_ty] [_int_mul, list_mul] ->- -- We ignore _int_mul because the integer (first- -- argument of fromListN) is statically known: it- -- is desugared to a literal. Therefore there is- -- no variable of which to scale the usage in that- -- first argument, and `_int_mul` is completely- -- free in this expression.- do { exprs' <-- mapM (tcScalingUsage list_mul . tc_elt elt_ty) exprs- ; return (exprs', elt_ty) }-- ; return $ ExplicitList elt_ty (Just fln') exprs' }- where tc_elt elt_ty expr = tcCheckPolyExpr expr elt_ty--{--************************************************************************-* *- Let, case, if, do-* *-************************************************************************--}--tcExpr (HsLet x (L l binds) expr) res_ty- = do { (binds', expr') <- tcLocalBinds binds $- tcLExpr expr res_ty- ; return (HsLet x (L l binds') expr') }--tcExpr (HsCase x scrut matches) res_ty- = do { -- We used to typecheck the case alternatives first.- -- The case patterns tend to give good type info to use- -- when typechecking the scrutinee. For example- -- case (map f) of- -- (x:xs) -> ...- -- will report that map is applied to too few arguments- --- -- But now, in the GADT world, we need to typecheck the scrutinee- -- first, to get type info that may be refined in the case alternatives- let mult = Many- -- There is not yet syntax or inference mechanism for case- -- expressions to be anything else than unrestricted.-- -- Typecheck the scrutinee. We use tcInferRho but tcInferSigma- -- would also be possible (tcMatchesCase accepts sigma-types)- -- Interesting litmus test: do these two behave the same?- -- case id of {..}- -- case (\v -> v) of {..}- -- This design choice is discussed in #17790- ; (scrut', scrut_ty) <- tcScalingUsage mult $ tcInferRho scrut-- ; traceTc "HsCase" (ppr scrut_ty)- ; matches' <- tcMatchesCase match_ctxt (Scaled mult scrut_ty) matches res_ty- ; return (HsCase x scrut' matches') }- where- match_ctxt = MC { mc_what = CaseAlt,- mc_body = tcBody }--tcExpr (HsIf x pred b1 b2) res_ty- = do { pred' <- tcLExpr pred (mkCheckExpType boolTy)- ; (u1,b1') <- tcCollectingUsage $ tcLExpr b1 res_ty- ; (u2,b2') <- tcCollectingUsage $ tcLExpr b2 res_ty- ; tcEmitBindingUsage (supUE u1 u2)- ; return (HsIf x pred' b1' b2') }--tcExpr (HsMultiIf _ alts) res_ty- = do { alts' <- mapM (wrapLocM $ tcGRHS match_ctxt res_ty) alts- ; res_ty <- readExpType res_ty- ; return (HsMultiIf res_ty alts') }- where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }--tcExpr (HsDo _ do_or_lc stmts) res_ty- = do { expr' <- tcDoStmts do_or_lc stmts res_ty- ; return expr' }--tcExpr (HsProc x pat cmd) res_ty- = do { (pat', cmd', coi) <- tcProc pat cmd res_ty- ; return $ mkHsWrapCo coi (HsProc x pat' cmd') }---- Typechecks the static form and wraps it with a call to 'fromStaticPtr'.--- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable for an overview.--- To type check--- (static e) :: p a--- we want to check (e :: a),--- and wrap (static e) in a call to--- fromStaticPtr :: IsStatic p => StaticPtr a -> p a--tcExpr (HsStatic fvs expr) res_ty- = do { res_ty <- expTypeToType res_ty- ; (co, (p_ty, expr_ty)) <- matchExpectedAppTy res_ty- ; (expr', lie) <- captureConstraints $- addErrCtxt (hang (text "In the body of a static form:")- 2 (ppr expr)- ) $- tcCheckPolyExprNC expr expr_ty-- -- Check that the free variables of the static form are closed.- -- It's OK to use nonDetEltsUniqSet here as the only side effects of- -- checkClosedInStaticForm are error messages.- ; mapM_ checkClosedInStaticForm $ nonDetEltsUniqSet fvs-- -- Require the type of the argument to be Typeable.- -- The evidence is not used, but asking the constraint ensures that- -- the current implementation is as restrictive as future versions- -- of the StaticPointers extension.- ; typeableClass <- tcLookupClass typeableClassName- ; _ <- emitWantedEvVar StaticOrigin $- mkTyConApp (classTyCon typeableClass)- [liftedTypeKind, expr_ty]-- -- Insert the constraints of the static form in a global list for later- -- validation.- ; emitStaticConstraints lie-- -- Wrap the static form with the 'fromStaticPtr' call.- ; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName- [p_ty]- ; let wrap = mkWpTyApps [expr_ty]- ; loc <- getSrcSpanM- ; return $ mkHsWrapCo co $ HsApp noExtField- (L loc $ mkHsWrap wrap fromStaticPtr)- (L loc (HsStatic fvs expr'))- }--{--************************************************************************-* *- Record construction and update-* *-************************************************************************--}--tcExpr expr@(RecordCon { rcon_con_name = L loc con_name- , rcon_flds = rbinds }) res_ty- = do { con_like <- tcLookupConLike con_name-- -- Check for missing fields- ; checkMissingFields con_like rbinds-- ; (con_expr, con_sigma) <- tcInferId con_name- ; (con_wrap, con_tau) <- topInstantiate orig con_sigma- -- a shallow instantiation should really be enough for- -- a data constructor.- ; let arity = conLikeArity con_like- Right (arg_tys, actual_res_ty) = tcSplitFunTysN arity con_tau- ; case conLikeWrapId_maybe con_like of {- Nothing -> nonBidirectionalErr (conLikeName con_like) ;- Just con_id ->-- do { rbinds' <- tcRecordBinds con_like (map scaledThing arg_tys) rbinds- -- It is currently not possible for a record to have- -- multiplicities. When they do, `tcRecordBinds` will take- -- scaled types instead. Meanwhile, it's safe to take- -- `scaledThing` above, as we know all the multiplicities are- -- Many.- ; let rcon_tc = RecordConTc- { rcon_con_like = con_like- , rcon_con_expr = mkHsWrap con_wrap con_expr }- expr' = RecordCon { rcon_ext = rcon_tc- , rcon_con_name = L loc con_id- , rcon_flds = rbinds' }-- ; tcWrapResultMono expr expr' actual_res_ty res_ty } } }- where- orig = OccurrenceOf con_name--{--Note [Type of a record update]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The main complication with RecordUpd is that we need to explicitly-handle the *non-updated* fields. Consider:-- data T a b c = MkT1 { fa :: a, fb :: (b,c) }- | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c }- | MkT3 { fd :: a }-- upd :: T a b c -> (b',c) -> T a b' c- upd t x = t { fb = x}--The result type should be (T a b' c)-not (T a b c), because 'b' *is not* mentioned in a non-updated field-not (T a b' c'), because 'c' *is* mentioned in a non-updated field-NB that it's not good enough to look at just one constructor; we must-look at them all; cf #3219--After all, upd should be equivalent to:- upd t x = case t of- MkT1 p q -> MkT1 p x- MkT2 a b -> MkT2 p b- MkT3 d -> error ...--So we need to give a completely fresh type to the result record,-and then constrain it by the fields that are *not* updated ("p" above).-We call these the "fixed" type variables, and compute them in getFixedTyVars.--Note that because MkT3 doesn't contain all the fields being updated,-its RHS is simply an error, so it doesn't impose any type constraints.-Hence the use of 'relevant_cont'.--Note [Implicit type sharing]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-We also take into account any "implicit" non-update fields. For example- data T a b where { MkT { f::a } :: T a a; ... }-So the "real" type of MkT is: forall ab. (a~b) => a -> T a b--Then consider- upd t x = t { f=x }-We infer the type- upd :: T a b -> a -> T a b- upd (t::T a b) (x::a)- = case t of { MkT (co:a~b) (_:a) -> MkT co x }-We can't give it the more general type- upd :: T a b -> c -> T c b--Note [Criteria for update]-~~~~~~~~~~~~~~~~~~~~~~~~~~-We want to allow update for existentials etc, provided the updated-field isn't part of the existential. For example, this should be ok.- data T a where { MkT { f1::a, f2::b->b } :: T a }- f :: T a -> b -> T b- f t b = t { f1=b }--The criterion we use is this:-- The types of the updated fields- mention only the universally-quantified type variables- of the data constructor--NB: this is not (quite) the same as being a "naughty" record selector-(See Note [Naughty record selectors]) in GHC.Tc.TyCl), at least-in the case of GADTs. Consider- data T a where { MkT :: { f :: a } :: T [a] }-Then f is not "naughty" because it has a well-typed record selector.-But we don't allow updates for 'f'. (One could consider trying to-allow this, but it makes my head hurt. Badly. And no one has asked-for it.)--In principle one could go further, and allow- g :: T a -> T a- g t = t { f2 = \x -> x }-because the expression is polymorphic...but that seems a bridge too far.--Note [Data family example]-~~~~~~~~~~~~~~~~~~~~~~~~~~- data instance T (a,b) = MkT { x::a, y::b }- --->- data :TP a b = MkT { a::a, y::b }- coTP a b :: T (a,b) ~ :TP a b--Suppose r :: T (t1,t2), e :: t3-Then r { x=e } :: T (t3,t1)- --->- case r |> co1 of- MkT x y -> MkT e y |> co2- where co1 :: T (t1,t2) ~ :TP t1 t2- co2 :: :TP t3 t2 ~ T (t3,t2)-The wrapping with co2 is done by the constructor wrapper for MkT--Outgoing invariants-~~~~~~~~~~~~~~~~~~~-In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys):-- * cons are the data constructors to be updated-- * in_inst_tys, out_inst_tys have same length, and instantiate the- *representation* tycon of the data cons. In Note [Data- family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2]--Note [Mixed Record Field Updates]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider the following pattern synonym.-- data MyRec = MyRec { foo :: Int, qux :: String }-- pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2}--This allows updates such as the following-- updater :: MyRec -> MyRec- updater a = a {f1 = 1 }--It would also make sense to allow the following update (which we reject).-- updater a = a {f1 = 1, qux = "two" } ==? MyRec 1 "two"--This leads to confusing behaviour when the selectors in fact refer the same-field.-- updater a = a {f1 = 1, foo = 2} ==? ???--For this reason, we reject a mixture of pattern synonym and normal record-selectors in the same update block. Although of course we still allow the-following.-- updater a = (a {f1 = 1}) {foo = 2}-- > updater (MyRec 0 "str")- MyRec 2 "str"---}--tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty- = ASSERT( notNull rbnds )- do { -- STEP -2: typecheck the record_expr, the record to be updated- (record_expr', record_rho) <- tcScalingUsage Many $ tcInferRho record_expr- -- Record update drops some of the content of the record (namely the- -- content of the field being updated). As a consequence, unless the- -- field being updated is unrestricted in the record, or we need an- -- unrestricted record. Currently, we simply always require an- -- unrestricted record.- --- -- Consider the following example:- --- -- data R a = R { self :: a }- -- bad :: a ⊸ ()- -- bad x = let r = R x in case r { self = () } of { R x' -> x' }- --- -- This should definitely *not* typecheck.-- -- STEP -1 See Note [Disambiguating record fields]- -- After this we know that rbinds is unambiguous- ; rbinds <- disambiguateRecordBinds record_expr record_rho rbnds res_ty- ; let upd_flds = map (unLoc . hsRecFieldLbl . unLoc) rbinds- upd_fld_occs = map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds- sel_ids = map selectorAmbiguousFieldOcc upd_flds- -- STEP 0- -- Check that the field names are really field names- -- and they are all field names for proper records or- -- all field names for pattern synonyms.- ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name)- | fld <- rbinds,- -- Excludes class ops- let L loc sel_id = hsRecUpdFieldId (unLoc fld),- not (isRecordSelector sel_id),- let fld_name = idName sel_id ]- ; unless (null bad_guys) (sequence bad_guys >> failM)- -- See note [Mixed Record Selectors]- ; let (data_sels, pat_syn_sels) =- partition isDataConRecordSelector sel_ids- ; MASSERT( all isPatSynRecordSelector pat_syn_sels )- ; checkTc ( null data_sels || null pat_syn_sels )- ( mixedSelectors data_sels pat_syn_sels )-- -- STEP 1- -- Figure out the tycon and data cons from the first field name- ; let -- It's OK to use the non-tc splitters here (for a selector)- sel_id : _ = sel_ids-- mtycon :: Maybe TyCon- mtycon = case idDetails sel_id of- RecSelId (RecSelData tycon) _ -> Just tycon- _ -> Nothing-- con_likes :: [ConLike]- con_likes = case idDetails sel_id of- RecSelId (RecSelData tc) _- -> map RealDataCon (tyConDataCons tc)- RecSelId (RecSelPatSyn ps) _- -> [PatSynCon ps]- _ -> panic "tcRecordUpd"- -- NB: for a data type family, the tycon is the instance tycon-- relevant_cons = conLikesWithFields con_likes upd_fld_occs- -- A constructor is only relevant to this process if- -- it contains *all* the fields that are being updated- -- Other ones will cause a runtime error if they occur-- -- Step 2- -- Check that at least one constructor has all the named fields- -- i.e. has an empty set of bad fields returned by badFields- ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds con_likes)-- -- Take apart a representative constructor- ; let con1 = ASSERT( not (null relevant_cons) ) head relevant_cons- (con1_tvs, _, _, _prov_theta, req_theta, scaled_con1_arg_tys, _)- = conLikeFullSig con1- con1_arg_tys = map scaledThing scaled_con1_arg_tys- -- We can safely drop the fields' multiplicities because- -- they are currently always 1: there is no syntax for record- -- fields with other multiplicities yet. This way we don't need- -- to handle it in the rest of the function- con1_flds = map flLabel $ conLikeFieldLabels con1- con1_tv_tys = mkTyVarTys con1_tvs- con1_res_ty = case mtycon of- Just tc -> mkFamilyTyConApp tc con1_tv_tys- Nothing -> conLikeResTy con1 con1_tv_tys-- -- Check that we're not dealing with a unidirectional pattern- -- synonym- ; unless (isJust $ conLikeWrapId_maybe con1)- (nonBidirectionalErr (conLikeName con1))-- -- STEP 3 Note [Criteria for update]- -- Check that each updated field is polymorphic; that is, its type- -- mentions only the universally-quantified variables of the data con- ; let flds1_w_tys = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys- bad_upd_flds = filter bad_fld flds1_w_tys- con1_tv_set = mkVarSet con1_tvs- bad_fld (fld, ty) = fld `elem` upd_fld_occs &&- not (tyCoVarsOfType ty `subVarSet` con1_tv_set)- ; checkTc (null bad_upd_flds) (badFieldTypes bad_upd_flds)-- -- STEP 4 Note [Type of a record update]- -- Figure out types for the scrutinee and result- -- Both are of form (T a b c), with fresh type variables, but with- -- common variables where the scrutinee and result must have the same type- -- These are variables that appear in *any* arg of *any* of the- -- relevant constructors *except* in the updated fields- --- ; let fixed_tvs = getFixedTyVars upd_fld_occs con1_tvs relevant_cons- is_fixed_tv tv = tv `elemVarSet` fixed_tvs-- mk_inst_ty :: TCvSubst -> (TyVar, TcType) -> TcM (TCvSubst, TcType)- -- Deals with instantiation of kind variables- -- c.f. GHC.Tc.Utils.TcMType.newMetaTyVars- mk_inst_ty subst (tv, result_inst_ty)- | is_fixed_tv tv -- Same as result type- = return (extendTvSubst subst tv result_inst_ty, result_inst_ty)- | otherwise -- Fresh type, of correct kind- = do { (subst', new_tv) <- newMetaTyVarX subst tv- ; return (subst', mkTyVarTy new_tv) }-- ; (result_subst, con1_tvs') <- newMetaTyVars con1_tvs- ; let result_inst_tys = mkTyVarTys con1_tvs'- init_subst = mkEmptyTCvSubst (getTCvInScope result_subst)-- ; (scrut_subst, scrut_inst_tys) <- mapAccumLM mk_inst_ty init_subst- (con1_tvs `zip` result_inst_tys)-- ; let rec_res_ty = TcType.substTy result_subst con1_res_ty- scrut_ty = TcType.substTy scrut_subst con1_res_ty- con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys-- ; co_scrut <- unifyType (Just (unLoc record_expr)) record_rho scrut_ty- -- NB: normal unification is OK here (as opposed to subsumption),- -- because for this to work out, both record_rho and scrut_ty have- -- to be normal datatypes -- no contravariant stuff can go on-- -- STEP 5- -- Typecheck the bindings- ; rbinds' <- tcRecordUpd con1 con1_arg_tys' rbinds-- -- STEP 6: Deal with the stupid theta- ; let theta' = substThetaUnchecked scrut_subst (conLikeStupidTheta con1)- ; instStupidTheta RecordUpdOrigin theta'-- -- Step 7: make a cast for the scrutinee, in the- -- case that it's from a data family- ; let fam_co :: HsWrapper -- RepT t1 .. tn ~R scrut_ty- fam_co | Just tycon <- mtycon- , Just co_con <- tyConFamilyCoercion_maybe tycon- = mkWpCastR (mkTcUnbranchedAxInstCo co_con scrut_inst_tys [])- | otherwise- = idHsWrapper-- -- Step 8: Check that the req constraints are satisfied- -- For normal data constructors req_theta is empty but we must do- -- this check for pattern synonyms.- ; let req_theta' = substThetaUnchecked scrut_subst req_theta- ; req_wrap <- instCallConstraints RecordUpdOrigin req_theta'-- -- Phew!- ; let upd_tc = RecordUpdTc { rupd_cons = relevant_cons- , rupd_in_tys = scrut_inst_tys- , rupd_out_tys = result_inst_tys- , rupd_wrap = req_wrap }- expr' = RecordUpd { rupd_expr = mkLHsWrap fam_co $- mkLHsWrapCo co_scrut record_expr'- , rupd_flds = rbinds'- , rupd_ext = upd_tc }-- ; tcWrapResult expr expr' rec_res_ty res_ty }--tcExpr e@(HsRecFld _ f) res_ty- = tcCheckRecSelId e f res_ty--{--************************************************************************-* *- Arithmetic sequences e.g. [a,b..]- and their parallel-array counterparts e.g. [: a,b.. :]--* *-************************************************************************--}--tcExpr (ArithSeq _ witness seq) res_ty- = tcArithSeq witness seq res_ty--{--************************************************************************-* *- Template Haskell-* *-************************************************************************--}---- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceExpr'.--- Here we get rid of it and add the finalizers to the global environment.------ See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice.-tcExpr (HsSpliceE _ (HsSpliced _ mod_finalizers (HsSplicedExpr expr)))- res_ty- = do addModFinalizersWithLclEnv mod_finalizers- tcExpr expr res_ty-tcExpr (HsSpliceE _ splice) res_ty = tcSpliceExpr splice res_ty-tcExpr e@(HsBracket _ brack) res_ty = tcTypedBracket e brack res_ty-tcExpr e@(HsRnBracketOut _ brack ps) res_ty = tcUntypedBracket e brack ps res_ty--{--************************************************************************-* *- Rebindable syntax-* *-************************************************************************--}---- See Note [Rebindable syntax and HsExpansion].-tcExpr (XExpr (HsExpanded a b)) t- = fmap (XExpr . ExpansionExpr . HsExpanded a) $- setSrcSpan generatedSrcSpan (tcExpr b t)--{--************************************************************************-* *- Catch-all-* *-************************************************************************--}--tcExpr other _ = pprPanic "tcLExpr" (ppr other)- -- Include ArrForm, ArrApp, which shouldn't appear at all- -- Also HsTcBracketOut, HsQuasiQuoteE---{- *********************************************************************-* *- Pragmas on expressions-* *-********************************************************************* -}--tcExprPrag :: HsPragE GhcRn -> HsPragE GhcTc-tcExprPrag (HsPragSCC x1 src ann) = HsPragSCC x1 src ann-tcExprPrag (HsPragTick x1 src info srcInfo) = HsPragTick x1 src info srcInfo---{- *********************************************************************-* *- Expression with type signature e::ty-* *-********************************************************************* -}--tcExprWithSig :: LHsExpr GhcRn -> LHsSigWcType (NoGhcTc GhcRn)- -> TcM (HsExpr GhcTc, TcSigmaType)-tcExprWithSig expr hs_ty- = do { sig_info <- checkNoErrs $ -- Avoid error cascade- tcUserTypeSig loc hs_ty Nothing- ; (expr', poly_ty) <- tcExprSig expr sig_info- ; return (ExprWithTySig noExtField expr' hs_ty, poly_ty) }- where- loc = getLoc (hsSigWcType hs_ty)--{--************************************************************************-* *- Arithmetic sequences [a..b] etc-* *-************************************************************************--}--tcArithSeq :: Maybe (SyntaxExpr GhcRn) -> ArithSeqInfo GhcRn -> ExpRhoType- -> TcM (HsExpr GhcTc)--tcArithSeq witness seq@(From expr) res_ty- = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty- ; expr' <-tcScalingUsage elt_mult $ tcCheckPolyExpr expr elt_ty- ; enum_from <- newMethodFromName (ArithSeqOrigin seq)- enumFromName [elt_ty]- ; return $ mkHsWrap wrap $- ArithSeq enum_from wit' (From expr') }--tcArithSeq witness seq@(FromThen expr1 expr2) res_ty- = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty- ; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty- ; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty- ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)- enumFromThenName [elt_ty]- ; return $ mkHsWrap wrap $- ArithSeq enum_from_then wit' (FromThen expr1' expr2') }--tcArithSeq witness seq@(FromTo expr1 expr2) res_ty- = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty- ; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty- ; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty- ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)- enumFromToName [elt_ty]- ; return $ mkHsWrap wrap $- ArithSeq enum_from_to wit' (FromTo expr1' expr2') }--tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty- = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty- ; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty- ; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty- ; expr3' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr3 elt_ty- ; eft <- newMethodFromName (ArithSeqOrigin seq)- enumFromThenToName [elt_ty]- ; return $ mkHsWrap wrap $- ArithSeq eft wit' (FromThenTo expr1' expr2' expr3') }--------------------arithSeqEltType :: Maybe (SyntaxExpr GhcRn) -> ExpRhoType- -> TcM (HsWrapper, Mult, TcType, Maybe (SyntaxExpr GhcTc))-arithSeqEltType Nothing res_ty- = do { res_ty <- expTypeToType res_ty- ; (coi, elt_ty) <- matchExpectedListTy res_ty- ; return (mkWpCastN coi, One, elt_ty, Nothing) }-arithSeqEltType (Just fl) res_ty- = do { ((elt_mult, elt_ty), fl')- <- tcSyntaxOp ListOrigin fl [SynList] res_ty $- \ [elt_ty] [elt_mult] -> return (elt_mult, elt_ty)- ; return (idHsWrapper, elt_mult, elt_ty, Just fl') }--{--************************************************************************-* *- Applications-* *-************************************************************************--}--{- Note [Typechecking applications]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We typecheck application chains (f e1 @ty e2) specially:--* So we can report errors like "in the third arument of a call of f"--* So we can do Visible Type Application (VTA), for which we must not- eagerly instantiate the function part of the application.--* So that we can do Quick Look impredicativity.--The idea is:--* Use collectHsArgs, which peels off- HsApp, HsTypeApp, HsPrag, HsPar- returning the function in the corner and the arguments--* Use tcInferAppHead to infer the type of the fuction,- as an (uninstantiated) TcSigmaType- There are special cases for- HsVar, HsREcFld, and ExprWithTySig- Otherwise, delegate back to tcExpr, which- infers an (instantiated) TcRhoType--Some cases that /won't/ work:--1. Consider this (which uses visible type application):-- (let { f :: forall a. a -> a; f x = x } in f) @Int-- Since 'let' is not among the special cases for tcInferAppHead,- we'll delegate back to tcExpr, which will instantiate f's type- and the type application to @Int will fail. Too bad!---}---- HsExprArg is a very local type, used only within this module.--- It's really a zipper for an application chain--- It's a GHC-specific type, so using TTG only where necessary-data HsExprArg id- = HsEValArg SrcSpan -- Of the function- (LHsExpr (GhcPass id))- | HsETypeArg SrcSpan -- Of the function- (LHsWcType (NoGhcTc (GhcPass id)))- !(XExprTypeArg id)- | HsEPrag SrcSpan- (HsPragE (GhcPass id))- | HsEPar SrcSpan -- Of the nested expr- | HsEWrap !(XArgWrap id) -- Wrapper, after typechecking only---- The outer location is the location of the application itself-type LHsExprArgIn = HsExprArg 'Renamed-type LHsExprArgOut = HsExprArg 'Typechecked--instance OutputableBndrId id => Outputable (HsExprArg id) where- ppr (HsEValArg _ tm) = ppr tm- ppr (HsEPrag _ p) = text "HsPrag" <+> ppr p- ppr (HsETypeArg _ hs_ty _) = char '@' <> ppr hs_ty- ppr (HsEPar _) = text "HsEPar"- ppr (HsEWrap w) = case ghcPass @id of- GhcTc -> text "HsEWrap" <+> ppr w- _ -> empty--type family XExprTypeArg id where- XExprTypeArg 'Parsed = NoExtField- XExprTypeArg 'Renamed = NoExtField- XExprTypeArg 'Typechecked = Type--type family XArgWrap id where- XArgWrap 'Parsed = NoExtCon- XArgWrap 'Renamed = NoExtCon- XArgWrap 'Typechecked = HsWrapper--addArgWrap :: HsWrapper -> [LHsExprArgOut] -> [LHsExprArgOut]-addArgWrap wrap args- | isIdHsWrapper wrap = args- | otherwise = HsEWrap wrap : args--collectHsArgs :: HsExpr GhcRn -> (HsExpr GhcRn, [LHsExprArgIn])-collectHsArgs e = go e []- where- go (HsPar _ (L l fun)) args = go fun (HsEPar l : args)- go (HsPragE _ p (L l fun)) args = go fun (HsEPrag l p : args)- go (HsApp _ (L l fun) arg) args = go fun (HsEValArg l arg : args)- go (HsAppType _ (L l fun) hs_ty) args = go fun (HsETypeArg l hs_ty noExtField : args)- go e args = (e,args)--applyHsArgs :: HsExpr GhcTc -> [LHsExprArgOut]-> HsExpr GhcTc-applyHsArgs fun args- = go fun args- where- go fun [] = fun- go fun (HsEWrap wrap : args) = go (mkHsWrap wrap fun) args- go fun (HsEValArg l arg : args) = go (HsApp noExtField (L l fun) arg) args- go fun (HsETypeArg l hs_ty ty : args) = go (HsAppType ty (L l fun) hs_ty) args- go fun (HsEPar l : args) = go (HsPar noExtField (L l fun)) args- go fun (HsEPrag l p : args) = go (HsPragE noExtField p (L l fun)) args--isHsValArg :: HsExprArg id -> Bool-isHsValArg (HsEValArg {}) = True-isHsValArg _ = False--isArgPar :: HsExprArg id -> Bool-isArgPar (HsEPar {}) = True-isArgPar _ = False--getFunLoc :: [HsExprArg 'Renamed] -> Maybe SrcSpan-getFunLoc [] = Nothing-getFunLoc (a:_) = Just $ case a of- HsEValArg l _ -> l- HsETypeArg l _ _ -> l- HsEPrag l _ -> l- HsEPar l -> l------------------------------tcApp :: HsExpr GhcRn -- either HsApp or HsAppType- -> ExpRhoType -> TcM (HsExpr GhcTc)--- See Note [Typechecking applications]-tcApp expr res_ty- = do { (fun, args, app_res_ty) <- tcInferApp expr- ; if isTagToEnum fun- then tcTagToEnum expr fun args app_res_ty res_ty- -- Done here because we have res_ty,- -- whereas tcInferApp does not- else-- -- The wildly common case- do { let expr' = applyHsArgs fun args- ; addFunResCtxt True fun app_res_ty res_ty $- tcWrapResult expr expr' app_res_ty res_ty } }------------------------------tcInferApp :: HsExpr GhcRn- -> TcM ( HsExpr GhcTc -- Function- , [LHsExprArgOut] -- Arguments- , TcSigmaType) -- Inferred type: a sigma-type!--- Also used by Module.tcRnExpr to implement GHCi :type-tcInferApp expr- | -- Gruesome special case for ambiguous record selectors- HsRecFld _ fld_lbl <- fun- , Ambiguous _ lbl <- fld_lbl -- Still ambiguous- , HsEValArg _ (L _ arg) : _ <- filterOut isArgPar args -- A value arg is first- , Just sig_ty <- obviousSig arg -- A type sig on the arg disambiguates- = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty- ; sel_name <- disambiguateSelector lbl sig_tc_ty- ; (tc_fun, fun_ty) <- tcInferRecSelId (Unambiguous sel_name lbl)- ; tcInferApp_finish fun tc_fun fun_ty args }-- | otherwise -- The wildly common case- = do { (tc_fun, fun_ty) <- set_fun_loc (tcInferAppHead fun)- ; tcInferApp_finish fun tc_fun fun_ty args }- where- (fun, args) = collectHsArgs expr- set_fun_loc thing_inside- = case getFunLoc args of- Nothing -> thing_inside -- Don't set the location twice- Just loc -> setSrcSpan loc thing_inside--tcInferApp_finish- :: HsExpr GhcRn -- Renamed function- -> HsExpr GhcTc -> TcSigmaType -- Function and its type- -> [LHsExprArgIn] -- Arguments- -> TcM (HsExpr GhcTc, [LHsExprArgOut], TcSigmaType)-tcInferApp_finish rn_fun tc_fun fun_sigma rn_args- = do { (tc_args, actual_res_ty) <- tcArgs rn_fun fun_sigma rn_args- ; return (tc_fun, tc_args, actual_res_ty) }--mk_op_msg :: LHsExpr GhcRn -> SDoc-mk_op_msg op = text "The operator" <+> quotes (ppr op) <+> text "takes"-------------------tcInferAppHead :: HsExpr GhcRn -> TcM (HsExpr GhcTc, TcSigmaType)--- Infer type of the head of an application, returning a /SigmaType/--- i.e. the 'f' in (f e1 ... en)--- We get back a SigmaType because we have special cases for--- * A bare identifier (just look it up)--- This case also covers a record selectro HsRecFld--- * An expression with a type signature (e :: ty)------ Note that [] and (,,) are both HsVar:--- see Note [Empty lists] and [ExplicitTuple] in GHC.Hs.Expr------ NB: 'e' cannot be HsApp, HsTyApp, HsPrag, HsPar, because those--- cases are dealt with by collectHsArgs.------ See Note [Typechecking applications]-tcInferAppHead e- = case e of- HsVar _ (L _ nm) -> tcInferId nm- HsRecFld _ f -> tcInferRecSelId f- ExprWithTySig _ e hs_ty -> add_ctxt $ tcExprWithSig e hs_ty- _ -> add_ctxt $ tcInfer (tcExpr e)- where- add_ctxt thing = addErrCtxt (exprCtxt e) thing--------------------- | Type-check the arguments to a function, possibly including visible type--- applications-tcArgs :: HsExpr GhcRn -- ^ The function itself (for err msgs only)- -> TcSigmaType -- ^ the (uninstantiated) type of the function- -> [LHsExprArgIn] -- ^ the args- -> TcM ([LHsExprArgOut], TcSigmaType)- -- ^ (a wrapper for the function, the tc'd args, result type)-tcArgs fun orig_fun_ty orig_args- = go 1 [] orig_fun_ty orig_args- where- fun_orig = exprCtOrigin fun- herald = sep [ text "The function" <+> quotes (ppr fun)- , text "is applied to"]-- -- Count value args only when complaining about a function- -- applied to too many value args- -- See Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify.- n_val_args = count isHsValArg orig_args-- fun_is_out_of_scope -- See Note [VTA for out-of-scope functions]- = case fun of- HsUnboundVar {} -> True- _ -> False-- go :: Int -- Which argment number this is (incl type args)- -> [Scaled TcSigmaType] -- Value args to which applied so far- -> TcSigmaType- -> [LHsExprArgIn] -> TcM ([LHsExprArgOut], TcSigmaType)- go _ _ fun_ty [] = traceTc "tcArgs:ret" (ppr fun_ty) >> return ([], fun_ty)-- go n so_far fun_ty (HsEPar sp : args)- = do { (args', res_ty) <- go n so_far fun_ty args- ; return (HsEPar sp : args', res_ty) }-- go n so_far fun_ty (HsEPrag sp prag : args)- = do { (args', res_ty) <- go n so_far fun_ty args- ; return (HsEPrag sp (tcExprPrag prag) : args', res_ty) }-- go n so_far fun_ty (HsETypeArg loc hs_ty_arg _ : args)- | fun_is_out_of_scope -- See Note [VTA for out-of-scope functions]- = go (n+1) so_far fun_ty args-- | otherwise- = do { (wrap1, upsilon_ty) <- topInstantiateInferred fun_orig fun_ty- -- wrap1 :: fun_ty "->" upsilon_ty- ; case tcSplitForAllTy_maybe upsilon_ty of- Just (tvb, inner_ty)- | binderArgFlag tvb == Specified ->- -- It really can't be Inferred, because we've justn- -- instantiated those. But, oddly, it might just be Required.- -- See Note [Required quantifiers in the type of a term]- do { let tv = binderVar tvb- kind = tyVarKind tv- ; ty_arg <- tcHsTypeApp hs_ty_arg kind-- ; inner_ty <- zonkTcType inner_ty- -- See Note [Visible type application zonk]- ; let in_scope = mkInScopeSet (tyCoVarsOfTypes [upsilon_ty, ty_arg])- insted_ty = substTyWithInScope in_scope [tv] [ty_arg] inner_ty- -- NB: tv and ty_arg have the same kind, so this- -- substitution is kind-respecting- ; traceTc "VTA" (vcat [ppr tv, debugPprType kind- , debugPprType ty_arg- , debugPprType (tcTypeKind ty_arg)- , debugPprType inner_ty- , debugPprType insted_ty ])-- ; (args', res_ty) <- go (n+1) so_far insted_ty args- ; return ( addArgWrap wrap1 $ HsETypeArg loc hs_ty_arg ty_arg : args'- , res_ty ) }- _ -> ty_app_err upsilon_ty hs_ty_arg }-- go n so_far fun_ty (HsEValArg loc arg : args)- = do { (wrap, arg_ty, res_ty)- <- matchActualFunTySigma herald fun_orig (Just fun)- (n_val_args, so_far) fun_ty- ; arg' <- tcArg fun arg arg_ty n- ; (args', inner_res_ty) <- go (n+1) (arg_ty:so_far) res_ty args- ; return ( addArgWrap wrap $ HsEValArg loc arg' : args'- , inner_res_ty ) }-- ty_app_err ty arg- = do { (_, ty) <- zonkTidyTcType emptyTidyEnv ty- ; failWith $- text "Cannot apply expression of type" <+> quotes (ppr ty) $$- text "to a visible type argument" <+> quotes (ppr arg) }--{- Note [Required quantifiers in the type of a term]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider (#15859)-- data A k :: k -> Type -- A :: forall k -> k -> Type- type KindOf (a :: k) = k -- KindOf :: forall k. k -> Type- a = (undefind :: KindOf A) @Int--With ImpredicativeTypes (thin ice, I know), we instantiate-KindOf at type (forall k -> k -> Type), so- KindOf A = forall k -> k -> Type-whose first argument is Required--We want to reject this type application to Int, but in earlier-GHCs we had an ASSERT that Required could not occur here.--The ice is thin; c.f. Note [No Required TyCoBinder in terms]-in GHC.Core.TyCo.Rep.--Note [VTA for out-of-scope functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose 'wurble' is not in scope, and we have- (wurble @Int @Bool True 'x')--Then the renamer will make (HsUnboundVar "wurble) for 'wurble',-and the typechecker will typecheck it with tcUnboundId, giving it-a type 'alpha', and emitting a deferred Hole, to be reported later.--But then comes the visible type application. If we do nothing, we'll-generate an immediate failure (in tc_app_err), saying that a function-of type 'alpha' can't be applied to Bool. That's insane! And indeed-users complain bitterly (#13834, #17150.)--The right error is the Hole, which has /already/ been emitted by-tcUnboundId. It later reports 'wurble' as out of scope, and tries to-give its type.--Fortunately in tcArgs we still have access to the function, so we can-check if it is a HsUnboundVar. We use this info to simply skip over-any visible type arguments. We've already inferred the type of the-function, so we'll /already/ have emitted a Hole;-failing preserves that constraint.--We do /not/ want to fail altogether in this case (via failM) becuase-that may abandon an entire instance decl, which (in the presence of--fdefer-type-errors) leads to leading to #17792.--Downside; the typechecked term has lost its visible type arguments; we-don't even kind-check them. But let's jump that bridge if we come to-it. Meanwhile, let's not crash!--Note [Visible type application zonk]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-* Substitutions should be kind-preserving, so we need kind(tv) = kind(ty_arg).--* tcHsTypeApp only guarantees that- - ty_arg is zonked- - kind(zonk(tv)) = kind(ty_arg)- (checkExpectedKind zonks as it goes).--So we must zonk inner_ty as well, to guarantee consistency between zonk(tv)-and inner_ty. Otherwise we can build an ill-kinded type. An example was-#14158, where we had:- id :: forall k. forall (cat :: k -> k -> *). forall (a :: k). cat a a-and we had the visible type application- id @(->)--* We instantiated k := kappa, yielding- forall (cat :: kappa -> kappa -> *). forall (a :: kappa). cat a a-* Then we called tcHsTypeApp (->) with expected kind (kappa -> kappa -> *).-* That instantiated (->) as ((->) q1 q1), and unified kappa := q1,- Here q1 :: RuntimeRep-* Now we substitute- cat :-> (->) q1 q1 :: TYPE q1 -> TYPE q1 -> *- but we must first zonk the inner_ty to get- forall (a :: TYPE q1). cat a a- so that the result of substitution is well-kinded- Failing to do so led to #14158.--}-------------------tcArg :: HsExpr GhcRn -- The function (for error messages)- -> LHsExpr GhcRn -- Actual arguments- -> Scaled TcSigmaType -- expected arg type- -> Int -- # of argument- -> TcM (LHsExpr GhcTc) -- Resulting argument-tcArg fun arg (Scaled mult ty) arg_no- = addErrCtxt (funAppCtxt fun arg arg_no) $- do { traceTc "tcArg" $- vcat [ ppr arg_no <+> text "of" <+> ppr fun- , text "arg type:" <+> ppr ty- , text "arg:" <+> ppr arg ]- ; tcScalingUsage mult $ tcCheckPolyExprNC arg ty }-------------------tcTupArgs :: [LHsTupArg GhcRn] -> [TcSigmaType] -> TcM [LHsTupArg GhcTc]-tcTupArgs args tys- = ASSERT( equalLength args tys ) mapM go (args `zip` tys)- where- go (L l (Missing {}), arg_ty) = do { mult <- newFlexiTyVarTy multiplicityTy- ; return (L l (Missing (Scaled mult arg_ty))) }- go (L l (Present x expr), arg_ty) = do { expr' <- tcCheckPolyExpr expr arg_ty- ; return (L l (Present x expr')) }-------------------------------- See TcType.SyntaxOpType also for commentary-tcSyntaxOp :: CtOrigin- -> SyntaxExprRn- -> [SyntaxOpType] -- ^ shape of syntax operator arguments- -> ExpRhoType -- ^ overall result type- -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ Type check any arguments,- -- takes a type per hole and a- -- multiplicity per arrow in- -- the shape.- -> TcM (a, SyntaxExprTc)--- ^ Typecheck a syntax operator--- The operator is a variable or a lambda at this stage (i.e. renamer--- output)-tcSyntaxOp orig expr arg_tys res_ty- = tcSyntaxOpGen orig expr arg_tys (SynType res_ty)---- | Slightly more general version of 'tcSyntaxOp' that allows the caller--- to specify the shape of the result of the syntax operator-tcSyntaxOpGen :: CtOrigin- -> SyntaxExprRn- -> [SyntaxOpType]- -> SyntaxOpType- -> ([TcSigmaType] -> [Mult] -> TcM a)- -> TcM (a, SyntaxExprTc)-tcSyntaxOpGen orig (SyntaxExprRn op) arg_tys res_ty thing_inside- = do { (expr, sigma) <- tcInferAppHead op- ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma)- ; (result, expr_wrap, arg_wraps, res_wrap)- <- tcSynArgA orig sigma arg_tys res_ty $- thing_inside- ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma )- ; return (result, SyntaxExprTc { syn_expr = mkHsWrap expr_wrap expr- , syn_arg_wraps = arg_wraps- , syn_res_wrap = res_wrap }) }-tcSyntaxOpGen _ NoSyntaxExprRn _ _ _ = panic "tcSyntaxOpGen"--{--Note [tcSynArg]-~~~~~~~~~~~~~~~-Because of the rich structure of SyntaxOpType, we must do the-contra-/covariant thing when working down arrows, to get the-instantiation vs. skolemisation decisions correct (and, more-obviously, the orientation of the HsWrappers). We thus have-two tcSynArgs.--}---- works on "expected" types, skolemising where necessary--- See Note [tcSynArg]-tcSynArgE :: CtOrigin- -> TcSigmaType- -> SyntaxOpType -- ^ shape it is expected to have- -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ check the arguments- -> TcM (a, HsWrapper)- -- ^ returns a wrapper :: (type of right shape) "->" (type passed in)-tcSynArgE orig sigma_ty syn_ty thing_inside- = do { (skol_wrap, (result, ty_wrapper))- <- tcSkolemise GenSigCtxt sigma_ty $ \ rho_ty ->- go rho_ty syn_ty- ; return (result, skol_wrap <.> ty_wrapper) }- where- go rho_ty SynAny- = do { result <- thing_inside [rho_ty] []- ; return (result, idHsWrapper) }-- go rho_ty SynRho -- same as SynAny, because we skolemise eagerly- = do { result <- thing_inside [rho_ty] []- ; return (result, idHsWrapper) }-- go rho_ty SynList- = do { (list_co, elt_ty) <- matchExpectedListTy rho_ty- ; result <- thing_inside [elt_ty] []- ; return (result, mkWpCastN list_co) }-- go rho_ty (SynFun arg_shape res_shape)- = do { ( match_wrapper -- :: (arg_ty -> res_ty) "->" rho_ty- , ( ( (result, arg_ty, res_ty, op_mult)- , res_wrapper ) -- :: res_ty_out "->" res_ty- , arg_wrapper1, [], arg_wrapper2 ) ) -- :: arg_ty "->" arg_ty_out- <- matchExpectedFunTys herald GenSigCtxt 1 (mkCheckExpType rho_ty) $- \ [arg_ty] res_ty ->- do { arg_tc_ty <- expTypeToType (scaledThing arg_ty)- ; res_tc_ty <- expTypeToType res_ty-- -- another nested arrow is too much for now,- -- but I bet we'll never need this- ; MASSERT2( case arg_shape of- SynFun {} -> False;- _ -> True- , text "Too many nested arrows in SyntaxOpType" $$- pprCtOrigin orig )-- ; let arg_mult = scaledMult arg_ty- ; tcSynArgA orig arg_tc_ty [] arg_shape $- \ arg_results arg_res_mults ->- tcSynArgE orig res_tc_ty res_shape $- \ res_results res_res_mults ->- do { result <- thing_inside (arg_results ++ res_results) ([arg_mult] ++ arg_res_mults ++ res_res_mults)- ; return (result, arg_tc_ty, res_tc_ty, arg_mult) }}-- ; return ( result- , match_wrapper <.>- mkWpFun (arg_wrapper2 <.> arg_wrapper1) res_wrapper- (Scaled op_mult arg_ty) res_ty doc ) }- where- herald = text "This rebindable syntax expects a function with"- doc = text "When checking a rebindable syntax operator arising from" <+> ppr orig-- go rho_ty (SynType the_ty)- = do { wrap <- tcSubTypePat orig GenSigCtxt the_ty rho_ty- ; result <- thing_inside [] []- ; return (result, wrap) }---- works on "actual" types, instantiating where necessary--- See Note [tcSynArg]-tcSynArgA :: CtOrigin- -> TcSigmaType- -> [SyntaxOpType] -- ^ argument shapes- -> SyntaxOpType -- ^ result shape- -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ check the arguments- -> TcM (a, HsWrapper, [HsWrapper], HsWrapper)- -- ^ returns a wrapper to be applied to the original function,- -- wrappers to be applied to arguments- -- and a wrapper to be applied to the overall expression-tcSynArgA orig sigma_ty arg_shapes res_shape thing_inside- = do { (match_wrapper, arg_tys, res_ty)- <- matchActualFunTysRho herald orig Nothing- (length arg_shapes) sigma_ty- -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty)- ; ((result, res_wrapper), arg_wrappers)- <- tc_syn_args_e (map scaledThing arg_tys) arg_shapes $ \ arg_results arg_res_mults ->- tc_syn_arg res_ty res_shape $ \ res_results ->- thing_inside (arg_results ++ res_results) (map scaledMult arg_tys ++ arg_res_mults)- ; return (result, match_wrapper, arg_wrappers, res_wrapper) }- where- herald = text "This rebindable syntax expects a function with"-- tc_syn_args_e :: [TcSigmaType] -> [SyntaxOpType]- -> ([TcSigmaType] -> [Mult] -> TcM a)- -> TcM (a, [HsWrapper])- -- the wrappers are for arguments- tc_syn_args_e (arg_ty : arg_tys) (arg_shape : arg_shapes) thing_inside- = do { ((result, arg_wraps), arg_wrap)- <- tcSynArgE orig arg_ty arg_shape $ \ arg1_results arg1_mults ->- tc_syn_args_e arg_tys arg_shapes $ \ args_results args_mults ->- thing_inside (arg1_results ++ args_results) (arg1_mults ++ args_mults)- ; return (result, arg_wrap : arg_wraps) }- tc_syn_args_e _ _ thing_inside = (, []) <$> thing_inside [] []-- tc_syn_arg :: TcSigmaType -> SyntaxOpType- -> ([TcSigmaType] -> TcM a)- -> TcM (a, HsWrapper)- -- the wrapper applies to the overall result- tc_syn_arg res_ty SynAny thing_inside- = do { result <- thing_inside [res_ty]- ; return (result, idHsWrapper) }- tc_syn_arg res_ty SynRho thing_inside- = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty- -- inst_wrap :: res_ty "->" rho_ty- ; result <- thing_inside [rho_ty]- ; return (result, inst_wrap) }- tc_syn_arg res_ty SynList thing_inside- = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty- -- inst_wrap :: res_ty "->" rho_ty- ; (list_co, elt_ty) <- matchExpectedListTy rho_ty- -- list_co :: [elt_ty] ~N rho_ty- ; result <- thing_inside [elt_ty]- ; return (result, mkWpCastN (mkTcSymCo list_co) <.> inst_wrap) }- tc_syn_arg _ (SynFun {}) _- = pprPanic "tcSynArgA hits a SynFun" (ppr orig)- tc_syn_arg res_ty (SynType the_ty) thing_inside- = do { wrap <- tcSubType orig GenSigCtxt res_ty the_ty- ; result <- thing_inside []- ; return (result, wrap) }--{--Note [Push result type in]-~~~~~~~~~~~~~~~~~~~~~~~~~~-Unify with expected result before type-checking the args so that the-info from res_ty percolates to args. This is when we might detect a-too-few args situation. (One can think of cases when the opposite-order would give a better error message.)-experimenting with putting this first.--Here's an example where it actually makes a real difference-- class C t a b | t a -> b- instance C Char a Bool-- data P t a = forall b. (C t a b) => MkP b- data Q t = MkQ (forall a. P t a)-- f1, f2 :: Q Char;- f1 = MkQ (MkP True)- f2 = MkQ (MkP True :: forall a. P Char a)--With the change, f1 will type-check, because the 'Char' info from-the signature is propagated into MkQ's argument. With the check-in the other order, the extra signature in f2 is reqd.--************************************************************************-* *- Expressions with a type signature- expr :: type-* *-********************************************************************* -}--tcExprSig :: LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcType)-tcExprSig expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc })- = setSrcSpan loc $ -- Sets the location for the implication constraint- do { let poly_ty = idType poly_id- ; (wrap, expr') <- tcSkolemiseScoped ExprSigCtxt poly_ty $ \rho_ty ->- tcCheckMonoExprNC expr rho_ty- ; return (mkLHsWrap wrap expr', poly_ty) }--tcExprSig expr sig@(PartialSig { psig_name = name, sig_loc = loc })- = setSrcSpan loc $ -- Sets the location for the implication constraint- do { (tclvl, wanted, (expr', sig_inst))- <- pushLevelAndCaptureConstraints $- do { sig_inst <- tcInstSig sig- ; expr' <- tcExtendNameTyVarEnv (mapSnd binderVar $ sig_inst_skols sig_inst) $- tcExtendNameTyVarEnv (sig_inst_wcs sig_inst) $- tcCheckPolyExprNC expr (sig_inst_tau sig_inst)- ; return (expr', sig_inst) }- -- See Note [Partial expression signatures]- ; let tau = sig_inst_tau sig_inst- infer_mode | null (sig_inst_theta sig_inst)- , isNothing (sig_inst_wcx sig_inst)- = ApplyMR- | otherwise- = NoRestrictions- ; (qtvs, givens, ev_binds, residual, _)- <- simplifyInfer tclvl infer_mode [sig_inst] [(name, tau)] wanted- ; emitConstraints residual-- ; tau <- zonkTcType tau- ; let inferred_theta = map evVarPred givens- tau_tvs = tyCoVarsOfType tau- ; (binders, my_theta) <- chooseInferredQuantifiers inferred_theta- tau_tvs qtvs (Just sig_inst)- ; let inferred_sigma = mkInfSigmaTy qtvs inferred_theta tau- my_sigma = mkInvisForAllTys binders (mkPhiTy my_theta tau)- ; wrap <- if inferred_sigma `eqType` my_sigma -- NB: eqType ignores vis.- then return idHsWrapper -- Fast path; also avoids complaint when we infer- -- an ambiguous type and have AllowAmbiguousType- -- e..g infer x :: forall a. F a -> Int- else tcSubTypeSigma ExprSigCtxt inferred_sigma my_sigma-- ; traceTc "tcExpSig" (ppr qtvs $$ ppr givens $$ ppr inferred_sigma $$ ppr my_sigma)- ; let poly_wrap = wrap- <.> mkWpTyLams qtvs- <.> mkWpLams givens- <.> mkWpLet ev_binds- ; return (mkLHsWrap poly_wrap expr', my_sigma) }---{- Note [Partial expression signatures]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Partial type signatures on expressions are easy to get wrong. But-here is a guiding principile- e :: ty-should behave like- let x :: ty- x = e- in x--So for partial signatures we apply the MR if no context is given. So- e :: IO _ apply the MR- e :: _ => IO _ do not apply the MR-just like in GHC.Tc.Gen.Bind.decideGeneralisationPlan--This makes a difference (#11670):- peek :: Ptr a -> IO CLong- peek ptr = peekElemOff undefined 0 :: _-from (peekElemOff undefined 0) we get- type: IO w- constraints: Storable w--We must NOT try to generalise over 'w' because the signature specifies-no constraints so we'll complain about not being able to solve-Storable w. Instead, don't generalise; then _ gets instantiated to-CLong, as it should.--}--{- *********************************************************************-* *- tcInferId-* *-********************************************************************* -}--tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTc)-tcCheckId name res_ty- | name `hasKey` tagToEnumKey- = failWithTc (text "tagToEnum# must appear applied to one argument")- -- tcApp catches the case (tagToEnum# arg)-- | otherwise- = do { (expr, actual_res_ty) <- tcInferId name- ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty])- ; addFunResCtxt False expr actual_res_ty res_ty $- tcWrapResultO (OccurrenceOf name) (HsVar noExtField (noLoc name)) expr- actual_res_ty res_ty }--tcCheckRecSelId :: HsExpr GhcRn -> AmbiguousFieldOcc GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)-tcCheckRecSelId rn_expr f@(Unambiguous {}) res_ty- = do { (expr, actual_res_ty) <- tcInferRecSelId f- ; tcWrapResult rn_expr expr actual_res_ty res_ty }-tcCheckRecSelId rn_expr (Ambiguous _ lbl) res_ty- = case tcSplitFunTy_maybe =<< checkingExpType_maybe res_ty of- Nothing -> ambiguousSelector lbl- Just (arg, _) -> do { sel_name <- disambiguateSelector lbl (scaledThing arg)- ; tcCheckRecSelId rn_expr (Unambiguous sel_name lbl)- res_ty }---------------------------tcInferRecSelId :: AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTc, TcRhoType)-tcInferRecSelId (Unambiguous sel (L _ lbl))- = do { (expr', ty) <- tc_infer_id lbl sel- ; return (expr', ty) }-tcInferRecSelId (Ambiguous _ lbl)- = ambiguousSelector lbl---------------------------tcInferId :: Name -> TcM (HsExpr GhcTc, TcSigmaType)--- Look up an occurrence of an Id--- Do not instantiate its type-tcInferId id_name- | id_name `hasKey` assertIdKey- = do { dflags <- getDynFlags- ; if gopt Opt_IgnoreAsserts dflags- then tc_infer_id (nameRdrName id_name) id_name- else tc_infer_assert id_name }-- | otherwise- = do { (expr, ty) <- tc_infer_id (nameRdrName id_name) id_name- ; traceTc "tcInferId" (ppr id_name <+> dcolon <+> ppr ty)- ; return (expr, ty) }--tc_infer_assert :: Name -> TcM (HsExpr GhcTc, TcSigmaType)--- Deal with an occurrence of 'assert'--- See Note [Adding the implicit parameter to 'assert']-tc_infer_assert assert_name- = do { assert_error_id <- tcLookupId assertErrorName- ; (wrap, id_rho) <- topInstantiate (OccurrenceOf assert_name)- (idType assert_error_id)- ; return (mkHsWrap wrap (HsVar noExtField (noLoc assert_error_id)), id_rho)- }--tc_infer_id :: RdrName -> Name -> TcM (HsExpr GhcTc, TcSigmaType)-tc_infer_id lbl id_name- = do { thing <- tcLookup id_name- ; case thing of- ATcId { tct_id = id }- -> do { check_naughty id -- Note [Local record selectors]- ; checkThLocalId id- ; tcEmitBindingUsage $ unitUE id_name One- ; return_id id }-- AGlobal (AnId id)- -> do { check_naughty id- ; return_id id }- -- A global cannot possibly be ill-staged- -- nor does it need the 'lifting' treatment- -- hence no checkTh stuff here-- AGlobal (AConLike cl) -> case cl of- RealDataCon con -> return_data_con con- PatSynCon ps -> tcPatSynBuilderOcc ps-- _ -> failWithTc $- ppr thing <+> text "used where a value identifier was expected" }- where- return_id id = return (HsVar noExtField (noLoc id), idType id)-- return_data_con con- = do { let tvs = dataConUserTyVarBinders con- theta = dataConOtherTheta con- args = dataConOrigArgTys con- res = dataConOrigResTy con-- -- See Note [Linear fields generalization]- ; mul_vars <- newFlexiTyVarTys (length args) multiplicityTy- ; let scaleArgs args' = zipWithEqual "return_data_con" combine mul_vars args'- combine var (Scaled One ty) = Scaled var ty- combine _ scaled_ty = scaled_ty- -- The combine function implements the fact that, as- -- described in Note [Linear fields generalization], if a- -- field is not linear (last line) it isn't made polymorphic.-- etaWrapper arg_tys = foldr (\scaled_ty wr -> WpFun WpHole wr scaled_ty empty) WpHole arg_tys-- -- See Note [Instantiating stupid theta]- ; let shouldInstantiate = (not (null (dataConStupidTheta con)) ||- isKindLevPoly (tyConResKind (dataConTyCon con)))- ; case shouldInstantiate of- True -> do { (subst, tvs') <- newMetaTyVars (binderVars tvs)- ; let tys' = mkTyVarTys tvs'- theta' = substTheta subst theta- args' = substScaledTys subst args- res' = substTy subst res- ; wrap <- instCall (OccurrenceOf id_name) tys' theta'- ; let scaled_arg_tys = scaleArgs args'- eta_wrap = etaWrapper scaled_arg_tys- ; addDataConStupidTheta con tys'- ; return ( mkHsWrap (eta_wrap <.> wrap)- (HsConLikeOut noExtField (RealDataCon con))- , mkVisFunTys scaled_arg_tys res')- }- False -> let scaled_arg_tys = scaleArgs args- wrap1 = mkWpTyApps (mkTyVarTys $ binderVars tvs)- eta_wrap = etaWrapper (map unrestricted theta ++ scaled_arg_tys)- wrap2 = mkWpTyLams $ binderVars tvs- in return ( mkHsWrap (wrap2 <.> eta_wrap <.> wrap1)- (HsConLikeOut noExtField (RealDataCon con))- , mkInvisForAllTys tvs $ mkInvisFunTysMany theta $ mkVisFunTys scaled_arg_tys res)- }-- check_naughty id- | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel lbl)- | otherwise = return ()---tcUnboundId :: HsExpr GhcRn -> OccName -> ExpRhoType -> TcM (HsExpr GhcTc)--- Typecheck an occurrence of an unbound Id------ Some of these started life as a true expression hole "_".--- Others might simply be variables that accidentally have no binding site------ We turn all of them into HsVar, since HsUnboundVar can't contain an--- Id; and indeed the evidence for the ExprHole does bind it, so it's--- not unbound any more!-tcUnboundId rn_expr occ res_ty- = do { ty <- newOpenFlexiTyVarTy -- Allow Int# etc (#12531)- ; name <- newSysName occ- ; let ev = mkLocalId name Many ty- ; emitNewExprHole occ ev ty- ; tcWrapResultO (UnboundOccurrenceOf occ) rn_expr- (HsVar noExtField (noLoc ev)) ty res_ty }---{--Note [Adding the implicit parameter to 'assert']-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The typechecker transforms (assert e1 e2) to (assertError e1 e2).-This isn't really the Right Thing because there's no way to "undo"-if you want to see the original source code in the typechecker-output. We'll have fix this in due course, when we care more about-being able to reconstruct the exact original program.--Note [tagToEnum#]-~~~~~~~~~~~~~~~~~-Nasty check to ensure that tagToEnum# is applied to a type that is an-enumeration TyCon. Unification may refine the type later, but this-check won't see that, alas. It's crude, because it relies on our-knowing *now* that the type is ok, which in turn relies on the-eager-unification part of the type checker pushing enough information-here. In theory the Right Thing to do is to have a new form of-constraint but I definitely cannot face that! And it works ok as-is.--Here's are two cases that should fail- f :: forall a. a- f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable-- g :: Int- g = tagToEnum# 0 -- Int is not an enumeration--When data type families are involved it's a bit more complicated.- data family F a- data instance F [Int] = A | B | C-Then we want to generate something like- tagToEnum# R:FListInt 3# |> co :: R:FListInt ~ F [Int]-Usually that coercion is hidden inside the wrappers for-constructors of F [Int] but here we have to do it explicitly.--It's all grotesquely complicated.--Note [Instantiating stupid theta]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Normally, when we infer the type of an Id, we don't instantiate,-because we wish to allow for visible type application later on.-But if a datacon has a stupid theta, we're a bit stuck. We need-to emit the stupid theta constraints with instantiated types. It's-difficult to defer this to the lazy instantiation, because a stupid-theta has no spot to put it in a type. So we just instantiate eagerly-in this case. Thus, users cannot use visible type application with-a data constructor sporting a stupid theta. I won't feel so bad for-the users that complain.--Note [Linear fields generalization]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-As per Note [Polymorphisation of linear fields], linear field of data-constructors get a polymorphic type when the data constructor is used as a term.-- Just :: forall {p} a. a #p-> Maybe a--This rule is known only to the typechecker: Just keeps its linear type in Core.--In order to desugar this generalised typing rule, we simply eta-expand:-- \a (x # p :: a) -> Just @a x--has the appropriate type. We insert these eta-expansion with WpFun wrappers.--A small hitch: if the constructor is levity-polymorphic (unboxed tuples, sums,-certain newtypes with -XUnliftedNewtypes) then this strategy produces-- \r1 r2 a b (x # p :: a) (y # q :: b) -> (# a, b #)--Which has type-- forall r1 r2 a b. a #p-> b #q-> (# a, b #)--Which violates the levity-polymorphism restriction see Note [Levity polymorphism-checking] in DsMonad.--So we really must instantiate r1 and r2 rather than quantify over them. For-simplicity, we just instantiate the entire type, as described in Note-[Instantiating stupid theta]. It breaks visible type application with unboxed-tuples, sums and levity-polymorphic newtypes, but this doesn't appear to be used-anywhere.--A better plan: let's force all representation variable to be *inferred*, so that-they are not subject to visible type applications. Then we can instantiate-inferred argument eagerly.--}--isTagToEnum :: HsExpr GhcTc -> Bool-isTagToEnum (HsVar _ (L _ fun_id)) = fun_id `hasKey` tagToEnumKey-isTagToEnum _ = False--tcTagToEnum :: HsExpr GhcRn -> HsExpr GhcTc -> [LHsExprArgOut]- -> TcSigmaType -> ExpRhoType- -> TcM (HsExpr GhcTc)--- tagToEnum# :: forall a. Int# -> a--- See Note [tagToEnum#] Urgh!-tcTagToEnum expr fun args app_res_ty res_ty- = do { res_ty <- readExpType res_ty- ; ty' <- zonkTcType res_ty-- -- Check that the type is algebraic- ; case tcSplitTyConApp_maybe ty' of {- Nothing -> do { addErrTc (mk_error ty' doc1)- ; vanilla_result } ;- Just (tc, tc_args) ->-- do { -- Look through any type family- ; fam_envs <- tcGetFamInstEnvs- ; case tcLookupDataFamInst_maybe fam_envs tc tc_args of {- Nothing -> do { check_enumeration ty' tc- ; vanilla_result } ;- Just (rep_tc, rep_args, coi) ->-- do { -- coi :: tc tc_args ~R rep_tc rep_args- check_enumeration ty' rep_tc- ; let val_arg = dropWhile (not . isHsValArg) args- rep_ty = mkTyConApp rep_tc rep_args- fun' = mkHsWrap (WpTyApp rep_ty) fun- expr' = applyHsArgs fun' val_arg- df_wrap = mkWpCastR (mkTcSymCo coi)- ; return (mkHsWrap df_wrap expr') }}}}}-- where- vanilla_result- = do { let expr' = applyHsArgs fun args- ; tcWrapResult expr expr' app_res_ty res_ty }-- check_enumeration ty' tc- | isEnumerationTyCon tc = return ()- | otherwise = addErrTc (mk_error ty' doc2)-- doc1 = vcat [ text "Specify the type by giving a type signature"- , text "e.g. (tagToEnum# x) :: Bool" ]- doc2 = text "Result type must be an enumeration type"-- mk_error :: TcType -> SDoc -> SDoc- mk_error ty what- = hang (text "Bad call to tagToEnum#"- <+> text "at type" <+> ppr ty)- 2 what--{--************************************************************************-* *- Template Haskell checks-* *-************************************************************************--}--checkThLocalId :: Id -> TcM ()--- The renamer has already done checkWellStaged,--- in 'GHC.Rename.Splice.checkThLocalName', so don't repeat that here.--- Here we just add constraints fro cross-stage lifting-checkThLocalId id- = do { mb_local_use <- getStageAndBindLevel (idName id)- ; case mb_local_use of- Just (top_lvl, bind_lvl, use_stage)- | thLevel use_stage > bind_lvl- -> checkCrossStageLifting top_lvl id use_stage- _ -> return () -- Not a locally-bound thing, or- -- no cross-stage link- }-----------------------------------------checkCrossStageLifting :: TopLevelFlag -> Id -> ThStage -> TcM ()--- If we are inside typed brackets, and (use_lvl > bind_lvl)--- we must check whether there's a cross-stage lift to do--- Examples \x -> [|| x ||]--- [|| map ||]------ This is similar to checkCrossStageLifting in GHC.Rename.Splice, but--- this code is applied to *typed* brackets.--checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var q))- | isTopLevel top_lvl- = when (isExternalName id_name) (keepAlive id_name)- -- See Note [Keeping things alive for Template Haskell] in GHC.Rename.Splice-- | otherwise- = -- Nested identifiers, such as 'x' in- -- E.g. \x -> [|| h x ||]- -- We must behave as if the reference to x was- -- h $(lift x)- -- We use 'x' itself as the splice proxy, used by- -- the desugarer to stitch it all back together.- -- If 'x' occurs many times we may get many identical- -- bindings of the same splice proxy, but that doesn't- -- matter, although it's a mite untidy.- do { let id_ty = idType id- ; checkTc (isTauTy id_ty) (polySpliceErr id)- -- If x is polymorphic, its occurrence sites might- -- have different instantiations, so we can't use plain- -- 'x' as the splice proxy name. I don't know how to- -- solve this, and it's probably unimportant, so I'm- -- just going to flag an error for now-- ; lift <- if isStringTy id_ty then- do { sid <- tcLookupId GHC.Builtin.Names.TH.liftStringName- -- See Note [Lifting strings]- ; return (HsVar noExtField (noLoc sid)) }- else- setConstraintVar lie_var $- -- Put the 'lift' constraint into the right LIE- newMethodFromName (OccurrenceOf id_name)- GHC.Builtin.Names.TH.liftName- [getRuntimeRep id_ty, id_ty]-- -- Update the pending splices- ; ps <- readMutVar ps_var- ; let pending_splice = PendingTcSplice id_name- (nlHsApp (mkLHsWrap (applyQuoteWrapper q) (noLoc lift))- (nlHsVar id))- ; writeMutVar ps_var (pending_splice : ps)-- ; return () }- where- id_name = idName id--checkCrossStageLifting _ _ _ = return ()--polySpliceErr :: Id -> SDoc-polySpliceErr id- = text "Can't splice the polymorphic local variable" <+> quotes (ppr id)--{--Note [Lifting strings]-~~~~~~~~~~~~~~~~~~~~~~-If we see $(... [| s |] ...) where s::String, we don't want to-generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc.-So this conditional short-circuits the lifting mechanism to generate-(liftString "xy") in that case. I didn't want to use overlapping instances-for the Lift class in TH.Syntax, because that can lead to overlapping-instance-errors in a polymorphic situation.--If this check fails (which isn't impossible) we get another chance; see-Note [Converting strings] in "GHC.ThToHs"--Local record selectors-~~~~~~~~~~~~~~~~~~~~~~-Record selectors for TyCons in this module are ordinary local bindings,-which show up as ATcIds rather than AGlobals. So we need to check for-naughtiness in both branches. c.f. TcTyClsBindings.mkAuxBinds.---************************************************************************-* *-\subsection{Record bindings}-* *-************************************************************************--}--getFixedTyVars :: [FieldLabelString] -> [TyVar] -> [ConLike] -> TyVarSet--- These tyvars must not change across the updates-getFixedTyVars upd_fld_occs univ_tvs cons- = mkVarSet [tv1 | con <- cons- , let (u_tvs, _, eqspec, prov_theta- , req_theta, arg_tys, _)- = conLikeFullSig con- theta = eqSpecPreds eqspec- ++ prov_theta- ++ req_theta- flds = conLikeFieldLabels con- fixed_tvs = exactTyCoVarsOfTypes (map scaledThing fixed_tys)- -- fixed_tys: See Note [Type of a record update]- `unionVarSet` tyCoVarsOfTypes theta- -- Universally-quantified tyvars that- -- appear in any of the *implicit*- -- arguments to the constructor are fixed- -- See Note [Implicit type sharing]-- fixed_tys = [ty | (fl, ty) <- zip flds arg_tys- , not (flLabel fl `elem` upd_fld_occs)]- , (tv1,tv) <- univ_tvs `zip` u_tvs- , tv `elemVarSet` fixed_tvs ]--{--Note [Disambiguating record fields]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When the -XDuplicateRecordFields extension is used, and the renamer-encounters a record selector or update that it cannot immediately-disambiguate (because it involves fields that belong to multiple-datatypes), it will defer resolution of the ambiguity to the-typechecker. In this case, the `Ambiguous` constructor of-`AmbiguousFieldOcc` is used.--Consider the following definitions:-- data S = MkS { foo :: Int }- data T = MkT { foo :: Int, bar :: Int }- data U = MkU { bar :: Int, baz :: Int }--When the renamer sees `foo` as a selector or an update, it will not-know which parent datatype is in use.--For selectors, there are two possible ways to disambiguate:--1. Check if the pushed-in type is a function whose domain is a- datatype, for example:-- f s = (foo :: S -> Int) s-- g :: T -> Int- g = foo-- This is checked by `tcCheckRecSelId` when checking `HsRecFld foo`.--2. Check if the selector is applied to an argument that has a type- signature, for example:-- h = foo (s :: S)-- This is checked by `tcApp`.---Updates are slightly more complex. The `disambiguateRecordBinds`-function tries to determine the parent datatype in three ways:--1. Check for types that have all the fields being updated. For example:-- f x = x { foo = 3, bar = 2 }-- Here `f` must be updating `T` because neither `S` nor `U` have- both fields. This may also discover that no possible type exists.- For example the following will be rejected:-- f' x = x { foo = 3, baz = 3 }--2. Use the type being pushed in, if it is already a TyConApp. The- following are valid updates to `T`:-- g :: T -> T- g x = x { foo = 3 }-- g' x = x { foo = 3 } :: T--3. Use the type signature of the record expression, if it exists and- is a TyConApp. Thus this is valid update to `T`:-- h x = (x :: T) { foo = 3 }---Note that we do not look up the types of variables being updated, and-no constraint-solving is performed, so for example the following will-be rejected as ambiguous:-- let bad (s :: S) = foo s-- let r :: T- r = blah- in r { foo = 3 }-- \r. (r { foo = 3 }, r :: T )--We could add further tests, of a more heuristic nature. For example,-rather than looking for an explicit signature, we could try to infer-the type of the argument to a selector or the record expression being-updated, in case we are lucky enough to get a TyConApp straight-away. However, it might be hard for programmers to predict whether a-particular update is sufficiently obvious for the signature to be-omitted. Moreover, this might change the behaviour of typechecker in-non-obvious ways.--See also Note [HsRecField and HsRecUpdField] in GHC.Hs.Pat.--}---- Given a RdrName that refers to multiple record fields, and the type--- of its argument, try to determine the name of the selector that is--- meant.-disambiguateSelector :: Located RdrName -> Type -> TcM Name-disambiguateSelector lr@(L _ rdr) parent_type- = do { fam_inst_envs <- tcGetFamInstEnvs- ; case tyConOf fam_inst_envs parent_type of- Nothing -> ambiguousSelector lr- Just p ->- do { xs <- lookupParents rdr- ; let parent = RecSelData p- ; case lookup parent xs of- Just gre -> do { addUsedGRE True gre- ; return (gre_name gre) }- Nothing -> failWithTc (fieldNotInType parent rdr) } }---- This field name really is ambiguous, so add a suitable "ambiguous--- occurrence" error, then give up.-ambiguousSelector :: Located RdrName -> TcM a-ambiguousSelector (L _ rdr)- = do { addAmbiguousNameErr rdr- ; failM }---- | This name really is ambiguous, so add a suitable "ambiguous--- occurrence" error, then continue-addAmbiguousNameErr :: RdrName -> TcM ()-addAmbiguousNameErr rdr- = do { env <- getGlobalRdrEnv- ; let gres = lookupGRE_RdrName rdr env- ; setErrCtxt [] $ addNameClashErrRn rdr gres}---- Disambiguate the fields in a record update.--- See Note [Disambiguating record fields]-disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType- -> [LHsRecUpdField GhcRn] -> ExpRhoType- -> TcM [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]-disambiguateRecordBinds record_expr record_rho rbnds res_ty- -- Are all the fields unambiguous?- = case mapM isUnambiguous rbnds of- -- If so, just skip to looking up the Ids- -- Always the case if DuplicateRecordFields is off- Just rbnds' -> mapM lookupSelector rbnds'- Nothing -> -- If not, try to identify a single parent- do { fam_inst_envs <- tcGetFamInstEnvs- -- Look up the possible parents for each field- ; rbnds_with_parents <- getUpdFieldsParents- ; let possible_parents = map (map fst . snd) rbnds_with_parents- -- Identify a single parent- ; p <- identifyParent fam_inst_envs possible_parents- -- Pick the right selector with that parent for each field- ; checkNoErrs $ mapM (pickParent p) rbnds_with_parents }- where- -- Extract the selector name of a field update if it is unambiguous- isUnambiguous :: LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn,Name)- isUnambiguous x = case unLoc (hsRecFieldLbl (unLoc x)) of- Unambiguous sel_name _ -> Just (x, sel_name)- Ambiguous{} -> Nothing-- -- Look up the possible parents and selector GREs for each field- getUpdFieldsParents :: TcM [(LHsRecUpdField GhcRn- , [(RecSelParent, GlobalRdrElt)])]- getUpdFieldsParents- = fmap (zip rbnds) $ mapM- (lookupParents . unLoc . hsRecUpdFieldRdr . unLoc)- rbnds-- -- Given a the lists of possible parents for each field,- -- identify a single parent- identifyParent :: FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent- identifyParent fam_inst_envs possible_parents- = case foldr1 intersect possible_parents of- -- No parents for all fields: record update is ill-typed- [] -> failWithTc (noPossibleParents rbnds)-- -- Exactly one datatype with all the fields: use that- [p] -> return p-- -- Multiple possible parents: try harder to disambiguate- -- Can we get a parent TyCon from the pushed-in type?- _:_ | Just p <- tyConOfET fam_inst_envs res_ty -> return (RecSelData p)-- -- Does the expression being updated have a type signature?- -- If so, try to extract a parent TyCon from it- | Just {} <- obviousSig (unLoc record_expr)- , Just tc <- tyConOf fam_inst_envs record_rho- -> return (RecSelData tc)-- -- Nothing else we can try...- _ -> failWithTc badOverloadedUpdate-- -- Make a field unambiguous by choosing the given parent.- -- Emits an error if the field cannot have that parent,- -- e.g. if the user writes- -- r { x = e } :: T- -- where T does not have field x.- pickParent :: RecSelParent- -> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])- -> TcM (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))- pickParent p (upd, xs)- = case lookup p xs of- -- Phew! The parent is valid for this field.- -- Previously ambiguous fields must be marked as- -- used now that we know which one is meant, but- -- unambiguous ones shouldn't be recorded again- -- (giving duplicate deprecation warnings).- Just gre -> do { unless (null (tail xs)) $ do- let L loc _ = hsRecFieldLbl (unLoc upd)- setSrcSpan loc $ addUsedGRE True gre- ; lookupSelector (upd, gre_name gre) }- -- The field doesn't belong to this parent, so report- -- an error but keep going through all the fields- Nothing -> do { addErrTc (fieldNotInType p- (unLoc (hsRecUpdFieldRdr (unLoc upd))))- ; lookupSelector (upd, gre_name (snd (head xs))) }-- -- Given a (field update, selector name) pair, look up the- -- selector to give a field update with an unambiguous Id- lookupSelector :: (LHsRecUpdField GhcRn, Name)- -> TcM (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))- lookupSelector (L l upd, n)- = do { i <- tcLookupId n- ; let L loc af = hsRecFieldLbl upd- lbl = rdrNameAmbiguousFieldOcc af- ; return $ L l upd { hsRecFieldLbl- = L loc (Unambiguous i (L loc lbl)) } }----- Extract the outermost TyCon of a type, if there is one; for--- data families this is the representation tycon (because that's--- where the fields live).-tyConOf :: FamInstEnvs -> TcSigmaType -> Maybe TyCon-tyConOf fam_inst_envs ty0- = case tcSplitTyConApp_maybe ty of- Just (tc, tys) -> Just (fstOf3 (tcLookupDataFamInst fam_inst_envs tc tys))- Nothing -> Nothing- where- (_, _, ty) = tcSplitSigmaTy ty0---- Variant of tyConOf that works for ExpTypes-tyConOfET :: FamInstEnvs -> ExpRhoType -> Maybe TyCon-tyConOfET fam_inst_envs ty0 = tyConOf fam_inst_envs =<< checkingExpType_maybe ty0---- For an ambiguous record field, find all the candidate record--- selectors (as GlobalRdrElts) and their parents.-lookupParents :: RdrName -> RnM [(RecSelParent, GlobalRdrElt)]-lookupParents rdr- = do { env <- getGlobalRdrEnv- ; let gres = lookupGRE_RdrName rdr env- ; mapM lookupParent gres }- where- lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt)- lookupParent gre = do { id <- tcLookupId (gre_name gre)- ; if isRecordSelector id- then return (recordSelectorTyCon id, gre)- else failWithTc (notSelector (gre_name gre)) }---- A type signature on the argument of an ambiguous record selector or--- the record expression in an update must be "obvious", i.e. the--- outermost constructor ignoring parentheses.-obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)-obviousSig (ExprWithTySig _ _ ty) = Just ty-obviousSig (HsPar _ p) = obviousSig (unLoc p)-obviousSig _ = Nothing---{--Game plan for record bindings-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-1. Find the TyCon for the bindings, from the first field label.--2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.--For each binding field = value--3. Instantiate the field type (from the field label) using the type- envt from step 2.--4 Type check the value using tcArg, passing the field type as- the expected argument type.--This extends OK when the field types are universally quantified.--}--tcRecordBinds- :: ConLike- -> [TcType] -- Expected type for each field- -> HsRecordBinds GhcRn- -> TcM (HsRecordBinds GhcTc)--tcRecordBinds con_like arg_tys (HsRecFields rbinds dd)- = do { mb_binds <- mapM do_bind rbinds- ; return (HsRecFields (catMaybes mb_binds) dd) }- where- fields = map flSelector $ conLikeFieldLabels con_like- flds_w_tys = zipEqual "tcRecordBinds" fields arg_tys-- do_bind :: LHsRecField GhcRn (LHsExpr GhcRn)- -> TcM (Maybe (LHsRecField GhcTc (LHsExpr GhcTc)))- do_bind (L l fld@(HsRecField { hsRecFieldLbl = f- , hsRecFieldArg = rhs }))-- = do { mb <- tcRecordField con_like flds_w_tys f rhs- ; case mb of- Nothing -> return Nothing- Just (f', rhs') -> return (Just (L l (fld { hsRecFieldLbl = f'- , hsRecFieldArg = rhs' }))) }--tcRecordUpd- :: ConLike- -> [TcType] -- Expected type for each field- -> [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]- -> TcM [LHsRecUpdField GhcTc]--tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds- where- fields = map flSelector $ conLikeFieldLabels con_like- flds_w_tys = zipEqual "tcRecordUpd" fields arg_tys-- do_bind :: LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)- -> TcM (Maybe (LHsRecUpdField GhcTc))- do_bind (L l fld@(HsRecField { hsRecFieldLbl = L loc af- , hsRecFieldArg = rhs }))- = do { let lbl = rdrNameAmbiguousFieldOcc af- sel_id = selectorAmbiguousFieldOcc af- f = L loc (FieldOcc (idName sel_id) (L loc lbl))- ; mb <- tcRecordField con_like flds_w_tys f rhs- ; case mb of- Nothing -> return Nothing- Just (f', rhs') ->- return (Just- (L l (fld { hsRecFieldLbl- = L loc (Unambiguous- (extFieldOcc (unLoc f'))- (L loc lbl))- , hsRecFieldArg = rhs' }))) }--tcRecordField :: ConLike -> Assoc Name Type- -> LFieldOcc GhcRn -> LHsExpr GhcRn- -> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))-tcRecordField con_like flds_w_tys (L loc (FieldOcc sel_name lbl)) rhs- | Just field_ty <- assocMaybe flds_w_tys sel_name- = addErrCtxt (fieldCtxt field_lbl) $- do { rhs' <- tcCheckPolyExprNC rhs field_ty- ; let field_id = mkUserLocal (nameOccName sel_name)- (nameUnique sel_name)- Many field_ty loc- -- Yuk: the field_id has the *unique* of the selector Id- -- (so we can find it easily)- -- but is a LocalId with the appropriate type of the RHS- -- (so the desugarer knows the type of local binder to make)- ; return (Just (L loc (FieldOcc field_id lbl), rhs')) }- | otherwise- = do { addErrTc (badFieldCon con_like field_lbl)- ; return Nothing }- where- field_lbl = occNameFS $ rdrNameOcc (unLoc lbl)---checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> TcM ()-checkMissingFields con_like rbinds- | null field_labels -- Not declared as a record;- -- But C{} is still valid if no strict fields- = if any isBanged field_strs then- -- Illegal if any arg is strict- addErrTc (missingStrictFields con_like [])- else do- warn <- woptM Opt_WarnMissingFields- when (warn && notNull field_strs && null field_labels)- (warnTc (Reason Opt_WarnMissingFields) True- (missingFields con_like []))-- | otherwise = do -- A record- unless (null missing_s_fields)- (addErrTc (missingStrictFields con_like missing_s_fields))-- warn <- woptM Opt_WarnMissingFields- when (warn && notNull missing_ns_fields)- (warnTc (Reason Opt_WarnMissingFields) True- (missingFields con_like missing_ns_fields))-- where- missing_s_fields- = [ flLabel fl | (fl, str) <- field_info,- isBanged str,- not (fl `elemField` field_names_used)- ]- missing_ns_fields- = [ flLabel fl | (fl, str) <- field_info,- not (isBanged str),- not (fl `elemField` field_names_used)- ]-- field_names_used = hsRecFields rbinds- field_labels = conLikeFieldLabels con_like-- field_info = zipEqual "missingFields"- field_labels- field_strs-- field_strs = conLikeImplBangs con_like-- fl `elemField` flds = any (\ fl' -> flSelector fl == fl') flds--{--************************************************************************-* *-\subsection{Errors and contexts}-* *-************************************************************************--Boring and alphabetical:--}--fieldCtxt :: FieldLabelString -> SDoc-fieldCtxt field_name- = text "In the" <+> quotes (ppr field_name) <+> ptext (sLit "field of a record")--addExprCtxt :: LHsExpr GhcRn -> TcRn a -> TcRn a-addExprCtxt e thing_inside = addErrCtxt (exprCtxt (unLoc e)) thing_inside--exprCtxt :: HsExpr GhcRn -> SDoc-exprCtxt expr = hang (text "In the expression:") 2 (ppr (stripParensHsExpr expr))--addFunResCtxt :: Bool -- There is at least one argument- -> HsExpr GhcTc -> TcType -> ExpRhoType- -> TcM a -> TcM a--- When we have a mis-match in the return type of a function--- try to give a helpful message about too many/few arguments------ Used for naked variables too; but with has_args = False-addFunResCtxt has_args fun fun_res_ty env_ty- = addLandmarkErrCtxtM (\env -> (env, ) <$> mk_msg)- -- NB: use a landmark error context, so that an empty context- -- doesn't suppress some more useful context- where- mk_msg- = do { mb_env_ty <- readExpType_maybe env_ty- -- by the time the message is rendered, the ExpType- -- will be filled in (except if we're debugging)- ; fun_res' <- zonkTcType fun_res_ty- ; env' <- case mb_env_ty of- Just env_ty -> zonkTcType env_ty- Nothing ->- do { dumping <- doptM Opt_D_dump_tc_trace- ; MASSERT( dumping )- ; newFlexiTyVarTy liftedTypeKind }- ; let -- See Note [Splitting nested sigma types in mismatched- -- function types]- (_, _, fun_tau) = tcSplitNestedSigmaTys fun_res'- -- No need to call tcSplitNestedSigmaTys here, since env_ty is- -- an ExpRhoTy, i.e., it's already instantiated.- (_, _, env_tau) = tcSplitSigmaTy env'- (args_fun, res_fun) = tcSplitFunTys fun_tau- (args_env, res_env) = tcSplitFunTys env_tau- n_fun = length args_fun- n_env = length args_env- info | n_fun == n_env = Outputable.empty- | n_fun > n_env- , not_fun res_env- = text "Probable cause:" <+> quotes (ppr fun)- <+> text "is applied to too few arguments"-- | has_args- , not_fun res_fun- = text "Possible cause:" <+> quotes (ppr fun)- <+> text "is applied to too many arguments"-- | otherwise- = Outputable.empty -- Never suggest that a naked variable is -- applied to too many args!- ; return info }- where- not_fun ty -- ty is definitely not an arrow type,- -- and cannot conceivably become one- = case tcSplitTyConApp_maybe ty of- Just (tc, _) -> isAlgTyCon tc- Nothing -> False--{--Note [Splitting nested sigma types in mismatched function types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When one applies a function to too few arguments, GHC tries to determine this-fact if possible so that it may give a helpful error message. It accomplishes-this by checking if the type of the applied function has more argument types-than supplied arguments.--Previously, GHC computed the number of argument types through tcSplitSigmaTy.-This is incorrect in the face of nested foralls, however! This caused Trac-#13311, for instance:-- f :: forall a. (Monoid a) => forall b. (Monoid b) => Maybe a -> Maybe b--If one uses `f` like so:-- do { f; putChar 'a' }--Then tcSplitSigmaTy will decompose the type of `f` into:-- Tyvars: [a]- Context: (Monoid a)- Argument types: []- Return type: forall b. Monoid b => Maybe a -> Maybe b--That is, it will conclude that there are *no* argument types, and since `f`-was given no arguments, it won't print a helpful error message. On the other-hand, tcSplitNestedSigmaTys correctly decomposes `f`'s type down to:-- Tyvars: [a, b]- Context: (Monoid a, Monoid b)- Argument types: [Maybe a]- Return type: Maybe b--So now GHC recognizes that `f` has one more argument type than it was actually-provided.--}--badFieldTypes :: [(FieldLabelString,TcType)] -> SDoc-badFieldTypes prs- = hang (text "Record update for insufficiently polymorphic field"- <> plural prs <> colon)- 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ])--badFieldsUpd- :: [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]- -- Field names that don't belong to a single datacon- -> [ConLike] -- Data cons of the type which the first field name belongs to- -> SDoc-badFieldsUpd rbinds data_cons- = hang (text "No constructor has all these fields:")- 2 (pprQuotedList conflictingFields)- -- See Note [Finding the conflicting fields]- where- -- A (preferably small) set of fields such that no constructor contains- -- all of them. See Note [Finding the conflicting fields]- conflictingFields = case nonMembers of- -- nonMember belongs to a different type.- (nonMember, _) : _ -> [aMember, nonMember]- [] -> let- -- All of rbinds belong to one type. In this case, repeatedly add- -- a field to the set until no constructor contains the set.-- -- Each field, together with a list indicating which constructors- -- have all the fields so far.- growingSets :: [(FieldLabelString, [Bool])]- growingSets = scanl1 combine membership- combine (_, setMem) (field, fldMem)- = (field, zipWith (&&) setMem fldMem)- in- -- Fields that don't change the membership status of the set- -- are redundant and can be dropped.- map (fst . head) $ groupBy ((==) `on` snd) growingSets-- aMember = ASSERT( not (null members) ) fst (head members)- (members, nonMembers) = partition (or . snd) membership-- -- For each field, which constructors contain the field?- membership :: [(FieldLabelString, [Bool])]- membership = sortMembership $- map (\fld -> (fld, map (Set.member fld) fieldLabelSets)) $- map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) rbinds-- fieldLabelSets :: [Set.Set FieldLabelString]- fieldLabelSets = map (Set.fromList . map flLabel . conLikeFieldLabels) data_cons-- -- Sort in order of increasing number of True, so that a smaller- -- conflicting set can be found.- sortMembership =- map snd .- sortBy (compare `on` fst) .- map (\ item@(_, membershipRow) -> (countTrue membershipRow, item))-- countTrue = count id--{--Note [Finding the conflicting fields]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have- data A = A {a0, a1 :: Int}- | B {b0, b1 :: Int}-and we see a record update- x { a0 = 3, a1 = 2, b0 = 4, b1 = 5 }-Then we'd like to find the smallest subset of fields that no-constructor has all of. Here, say, {a0,b0}, or {a0,b1}, etc.-We don't really want to report that no constructor has all of-{a0,a1,b0,b1}, because when there are hundreds of fields it's-hard to see what was really wrong.--We may need more than two fields, though; eg- data T = A { x,y :: Int, v::Int }- | B { y,z :: Int, v::Int }- | C { z,x :: Int, v::Int }-with update- r { x=e1, y=e2, z=e3 }, we--Finding the smallest subset is hard, so the code here makes-a decent stab, no more. See #7989.--}--naughtyRecordSel :: RdrName -> SDoc-naughtyRecordSel sel_id- = text "Cannot use record selector" <+> quotes (ppr sel_id) <+>- text "as a function due to escaped type variables" $$- text "Probable fix: use pattern-matching syntax instead"--notSelector :: Name -> SDoc-notSelector field- = hsep [quotes (ppr field), text "is not a record selector"]--mixedSelectors :: [Id] -> [Id] -> SDoc-mixedSelectors data_sels@(dc_rep_id:_) pat_syn_sels@(ps_rep_id:_)- = ptext- (sLit "Cannot use a mixture of pattern synonym and record selectors") $$- text "Record selectors defined by"- <+> quotes (ppr (tyConName rep_dc))- <> text ":"- <+> pprWithCommas ppr data_sels $$- text "Pattern synonym selectors defined by"- <+> quotes (ppr (patSynName rep_ps))- <> text ":"- <+> pprWithCommas ppr pat_syn_sels- where- RecSelPatSyn rep_ps = recordSelectorTyCon ps_rep_id- RecSelData rep_dc = recordSelectorTyCon dc_rep_id-mixedSelectors _ _ = panic "GHC.Tc.Gen.Expr: mixedSelectors emptylists"---missingStrictFields :: ConLike -> [FieldLabelString] -> SDoc-missingStrictFields con fields- = header <> rest- where- rest | null fields = Outputable.empty -- Happens for non-record constructors- -- with strict fields- | otherwise = colon <+> pprWithCommas ppr fields-- header = text "Constructor" <+> quotes (ppr con) <+>- text "does not have the required strict field(s)"--missingFields :: ConLike -> [FieldLabelString] -> SDoc-missingFields con fields- = header <> rest- where- rest | null fields = Outputable.empty- | otherwise = colon <+> pprWithCommas ppr fields- header = text "Fields of" <+> quotes (ppr con) <+>- text "not initialised"---- callCtxt fun args = text "In the call" <+> parens (ppr (foldl' mkHsApp fun args))--noPossibleParents :: [LHsRecUpdField GhcRn] -> SDoc-noPossibleParents rbinds- = hang (text "No type has all these fields:")- 2 (pprQuotedList fields)- where- fields = map (hsRecFieldLbl . unLoc) rbinds--badOverloadedUpdate :: SDoc-badOverloadedUpdate = text "Record update is ambiguous, and requires a type signature"--fieldNotInType :: RecSelParent -> RdrName -> SDoc-fieldNotInType p rdr- = unknownSubordinateErr (text "field of type" <+> quotes (ppr p)) rdr+ ( tcCheckPolyExpr, tcCheckPolyExprNC,+ tcCheckMonoExpr, tcCheckMonoExprNC, tcMonoExpr, tcMonoExprNC,+ tcInferRho, tcInferRhoNC,+ tcExpr,+ tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType,+ tcCheckId,+ addAmbiguousNameErr,+ getFixedTyVars ) where++#include "GhclibHsVersions.h"++import GHC.Prelude++import {-# SOURCE #-} GHC.Tc.Gen.Splice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket )++import GHC.Hs+import GHC.Tc.Utils.Zonk+import GHC.Tc.Utils.Monad+import GHC.Tc.Utils.Unify+import GHC.Types.Basic+import GHC.Core.Multiplicity+import GHC.Core.UsageEnv+import GHC.Tc.Utils.Instantiate+import GHC.Tc.Gen.App+import GHC.Tc.Gen.Head+import GHC.Tc.Gen.Bind ( tcLocalBinds )+import GHC.Tc.Instance.Family ( tcGetFamInstEnvs )+import GHC.Core.FamInstEnv ( FamInstEnvs )+import GHC.Rename.Env ( addUsedGRE )+import GHC.Tc.Utils.Env+import GHC.Tc.Gen.Arrow+import GHC.Tc.Gen.Match+import GHC.Tc.Gen.HsType+import GHC.Tc.Gen.Pat+import GHC.Tc.Utils.TcMType+import GHC.Tc.Types.Origin+import GHC.Tc.Utils.TcType as TcType+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Core.ConLike+import GHC.Core.DataCon+import GHC.Core.PatSyn+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Name.Set+import GHC.Types.Name.Reader+import GHC.Core.TyCon+import GHC.Core.Type+import GHC.Tc.Types.Evidence+import GHC.Types.Var.Set+import GHC.Builtin.Types+import GHC.Builtin.Names+import GHC.Driver.Session+import GHC.Types.SrcLoc+import GHC.Utils.Misc+import GHC.Data.List.SetOps+import GHC.Data.Maybe+import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic+import GHC.Data.FastString+import Control.Monad+import GHC.Core.Class(classTyCon)+import GHC.Types.Unique.Set ( UniqSet, mkUniqSet, elementOfUniqSet, nonDetEltsUniqSet )+import qualified GHC.LanguageExtensions as LangExt++import Data.Function+import Data.List (partition, sortBy, groupBy, intersect)++{-+************************************************************************+* *+\subsection{Main wrappers}+* *+************************************************************************+-}+++tcCheckPolyExpr, tcCheckPolyExprNC+ :: LHsExpr GhcRn -- Expression to type check+ -> TcSigmaType -- Expected type (could be a polytype)+ -> TcM (LHsExpr GhcTc) -- Generalised expr with expected type++-- tcCheckPolyExpr is a convenient place (frequent but not too frequent)+-- place to add context information.+-- The NC version does not do so, usually because the caller wants+-- to do so himself.++tcCheckPolyExpr expr res_ty = tcPolyExpr expr (mkCheckExpType res_ty)+tcCheckPolyExprNC expr res_ty = tcPolyExprNC expr (mkCheckExpType res_ty)++-- These versions take an ExpType+tcPolyExpr, tcPolyExprNC+ :: LHsExpr GhcRn -> ExpSigmaType+ -> TcM (LHsExpr GhcTc)++tcPolyExpr expr res_ty+ = addLExprCtxt expr $+ do { traceTc "tcPolyExpr" (ppr res_ty)+ ; tcPolyExprNC expr res_ty }++tcPolyExprNC (L loc expr) res_ty+ = set_loc_and_ctxt loc expr $+ do { traceTc "tcPolyExprNC" (ppr res_ty)+ ; (wrap, expr') <- tcSkolemiseET GenSigCtxt res_ty $ \ res_ty ->+ tcExpr expr res_ty+ ; return $ L loc (mkHsWrap wrap expr') }++ where -- See Note [Rebindable syntax and HsExpansion), which describes+ -- the logic behind this location/context tweaking.+ set_loc_and_ctxt l e m = do+ inGenCode <- inGeneratedCode+ if inGenCode && not (isGeneratedSrcSpan l)+ then setSrcSpan l $+ addExprCtxt e m+ else setSrcSpan l m++---------------+tcCheckMonoExpr, tcCheckMonoExprNC+ :: LHsExpr GhcRn -- Expression to type check+ -> TcRhoType -- Expected type+ -- Definitely no foralls at the top+ -> TcM (LHsExpr GhcTc)+tcCheckMonoExpr expr res_ty = tcMonoExpr expr (mkCheckExpType res_ty)+tcCheckMonoExprNC expr res_ty = tcMonoExprNC expr (mkCheckExpType res_ty)++tcMonoExpr, tcMonoExprNC+ :: LHsExpr GhcRn -- Expression to type check+ -> ExpRhoType -- Expected type+ -- Definitely no foralls at the top+ -> TcM (LHsExpr GhcTc)++tcMonoExpr expr res_ty+ = addLExprCtxt expr $+ tcMonoExprNC expr res_ty++tcMonoExprNC (L loc expr) res_ty+ = setSrcSpan loc $+ do { expr' <- tcExpr expr res_ty+ ; return (L loc expr') }++---------------+tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType)+-- Infer a *rho*-type. The return type is always instantiated.+tcInferRho le = addLExprCtxt le $+ tcInferRhoNC le++tcInferRhoNC (L loc expr)+ = setSrcSpan loc $+ do { (expr', rho) <- tcInfer (tcExpr expr)+ ; return (L loc expr', rho) }+++{- *********************************************************************+* *+ tcExpr: the main expression typechecker+* *+********************************************************************* -}++tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)++-- Use tcApp to typecheck appplications, which are treated specially+-- by Quick Look. Specifically:+-- - HsApp: value applications+-- - HsTypeApp: type applications+-- - HsVar: lone variables, to ensure that they can get an+-- impredicative instantiation (via Quick Look+-- driven by res_ty (in checking mode).+-- - ExprWithTySig: (e :: type)+-- See Note [Application chains and heads] in GHC.Tc.Gen.App+tcExpr e@(HsVar {}) res_ty = tcApp e res_ty+tcExpr e@(HsApp {}) res_ty = tcApp e res_ty+tcExpr e@(HsAppType {}) res_ty = tcApp e res_ty+tcExpr e@(ExprWithTySig {}) res_ty = tcApp e res_ty+tcExpr e@(HsRecFld {}) res_ty = tcApp e res_ty++-- Typecheck an occurrence of an unbound Id+--+-- Some of these started life as a true expression hole "_".+-- Others might simply be variables that accidentally have no binding site+tcExpr e@(HsUnboundVar _ occ) res_ty+ = do { ty <- newOpenFlexiTyVarTy -- Allow Int# etc (#12531)+ ; name <- newSysName occ+ ; let ev = mkLocalId name Many ty+ ; emitNewExprHole occ ev ty+ ; tcEmitBindingUsage bottomUE -- Holes fit any usage environment+ -- (#18491)+ ; tcWrapResultO (UnboundOccurrenceOf occ) e+ (HsUnboundVar ev occ) ty res_ty }++tcExpr e@(HsLit x lit) res_ty+ = do { let lit_ty = hsLitType lit+ ; tcWrapResult e (HsLit x (convertLit lit)) lit_ty res_ty }++tcExpr (HsPar x expr) res_ty+ = do { expr' <- tcMonoExprNC expr res_ty+ ; return (HsPar x expr') }++tcExpr (HsPragE x prag expr) res_ty+ = do { expr' <- tcMonoExpr expr res_ty+ ; return (HsPragE x (tcExprPrag prag) expr') }++tcExpr (HsOverLit x lit) res_ty+ = do { lit' <- newOverloadedLit lit res_ty+ ; return (HsOverLit x lit') }++tcExpr (NegApp x expr neg_expr) res_ty+ = do { (expr', neg_expr')+ <- tcSyntaxOp NegateOrigin neg_expr [SynAny] res_ty $+ \[arg_ty] [arg_mult] ->+ tcScalingUsage arg_mult $ tcCheckMonoExpr expr arg_ty+ ; return (NegApp x expr' neg_expr') }++tcExpr e@(HsIPVar _ x) res_ty+ = do { {- Implicit parameters must have a *tau-type* not a+ type scheme. We enforce this by creating a fresh+ type variable as its type. (Because res_ty may not+ be a tau-type.) -}+ ip_ty <- newOpenFlexiTyVarTy+ ; let ip_name = mkStrLitTy (hsIPNameFS x)+ ; ipClass <- tcLookupClass ipClassName+ ; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty])+ ; tcWrapResult e+ (fromDict ipClass ip_name ip_ty (HsVar noExtField (noLoc ip_var)))+ ip_ty res_ty }+ where+ -- Coerces a dictionary for `IP "x" t` into `t`.+ fromDict ipClass x ty = mkHsWrap $ mkWpCastR $+ unwrapIP $ mkClassPred ipClass [x,ty]+ origin = IPOccOrigin x++tcExpr e@(HsOverLabel _ mb_fromLabel l) res_ty+ = do { -- See Note [Type-checking overloaded labels]+ loc <- getSrcSpanM+ ; case mb_fromLabel of+ Just fromLabel -> tcExpr (applyFromLabel loc fromLabel) res_ty+ Nothing -> do { isLabelClass <- tcLookupClass isLabelClassName+ ; alpha <- newFlexiTyVarTy liftedTypeKind+ ; let pred = mkClassPred isLabelClass [lbl, alpha]+ ; loc <- getSrcSpanM+ ; var <- emitWantedEvVar origin pred+ ; tcWrapResult e+ (fromDict pred (HsVar noExtField (L loc var)))+ alpha res_ty } }+ where+ -- Coerces a dictionary for `IsLabel "x" t` into `t`,+ -- or `HasField "x" r a into `r -> a`.+ fromDict pred = mkHsWrap $ mkWpCastR $ unwrapIP pred+ origin = OverLabelOrigin l+ lbl = mkStrLitTy l++ applyFromLabel loc fromLabel =+ HsAppType noExtField+ (L loc (HsVar noExtField (L loc fromLabel)))+ (mkEmptyWildCardBndrs (L loc (HsTyLit noExtField (HsStrTy NoSourceText l))))++tcExpr (HsLam x match) res_ty+ = do { (wrap, match') <- tcMatchLambda herald match_ctxt match res_ty+ ; return (mkHsWrap wrap (HsLam x match')) }+ where+ match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody }+ herald = sep [ text "The lambda expression" <+>+ quotes (pprSetDepth (PartWay 1) $+ pprMatches match),+ -- The pprSetDepth makes the abstraction print briefly+ text "has"]++tcExpr e@(HsLamCase x matches) res_ty+ = do { (wrap, matches')+ <- tcMatchLambda msg match_ctxt matches res_ty+ -- The laziness annotation is because we don't want to fail here+ -- if there are multiple arguments+ ; return (mkHsWrap wrap $ HsLamCase x matches') }+ where+ msg = sep [ text "The function" <+> quotes (ppr e)+ , text "requires"]+ match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody }++{-+Note [Type-checking overloaded labels]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Recall that we have++ module GHC.OverloadedLabels where+ class IsLabel (x :: Symbol) a where+ fromLabel :: a++We translate `#foo` to `fromLabel @"foo"`, where we use++ * the in-scope `fromLabel` if `RebindableSyntax` is enabled; or if not+ * `GHC.OverloadedLabels.fromLabel`.++In the `RebindableSyntax` case, the renamer will have filled in the+first field of `HsOverLabel` with the `fromLabel` function to use, and+we simply apply it to the appropriate visible type argument.++In the `OverloadedLabels` case, when we see an overloaded label like+`#foo`, we generate a fresh variable `alpha` for the type and emit an+`IsLabel "foo" alpha` constraint. Because the `IsLabel` class has a+single method, it is represented by a newtype, so we can coerce+`IsLabel "foo" alpha` to `alpha` (just like for implicit parameters).++-}+++{-+************************************************************************+* *+ Infix operators and sections+* *+************************************************************************++Note [Left sections]+~~~~~~~~~~~~~~~~~~~~+Left sections, like (4 *), are equivalent to+ \ x -> (*) 4 x,+or, if PostfixOperators is enabled, just+ (*) 4+With PostfixOperators we don't actually require the function to take+two arguments at all. For example, (x `not`) means (not x); you get+postfix operators! Not Haskell 98, but it's less work and kind of+useful.+-}++tcExpr expr@(OpApp {}) res_ty+ = tcApp expr res_ty++-- Right sections, equivalent to \ x -> x `op` expr, or+-- \ x -> op x expr++tcExpr expr@(SectionR x op arg2) res_ty+ = do { (op', op_ty) <- tcInferRhoNC op+ ; (wrap_fun, [Scaled arg1_mult arg1_ty, arg2_ty], op_res_ty)+ <- matchActualFunTysRho (mk_op_msg op) fn_orig+ (Just (ppr op)) 2 op_ty+ ; arg2' <- tcValArg (unLoc op) arg2 arg2_ty 2+ ; let expr' = SectionR x (mkLHsWrap wrap_fun op') arg2'+ act_res_ty = mkVisFunTy arg1_mult arg1_ty op_res_ty+ ; tcWrapResultMono expr expr' act_res_ty res_ty }++ where+ fn_orig = lexprCtOrigin op+ -- It's important to use the origin of 'op', so that call-stacks+ -- come out right; they are driven by the OccurrenceOf CtOrigin+ -- See #13285++tcExpr expr@(SectionL x arg1 op) res_ty+ = do { (op', op_ty) <- tcInferRhoNC op+ ; dflags <- getDynFlags -- Note [Left sections]+ ; let n_reqd_args | xopt LangExt.PostfixOperators dflags = 1+ | otherwise = 2++ ; (wrap_fn, (arg1_ty:arg_tys), op_res_ty)+ <- matchActualFunTysRho (mk_op_msg op) fn_orig+ (Just (ppr op)) n_reqd_args op_ty+ ; arg1' <- tcValArg (unLoc op) arg1 arg1_ty 1+ ; let expr' = SectionL x arg1' (mkLHsWrap wrap_fn op')+ act_res_ty = mkVisFunTys arg_tys op_res_ty+ ; tcWrapResultMono expr expr' act_res_ty res_ty }+ where+ fn_orig = lexprCtOrigin op+ -- It's important to use the origin of 'op', so that call-stacks+ -- come out right; they are driven by the OccurrenceOf CtOrigin+ -- See #13285++tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty+ | all tupArgPresent tup_args+ = do { let arity = length tup_args+ tup_tc = tupleTyCon boxity arity+ -- NB: tupleTyCon doesn't flatten 1-tuples+ -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make+ ; res_ty <- expTypeToType res_ty+ ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty+ -- Unboxed tuples have RuntimeRep vars, which we+ -- don't care about here+ -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon+ ; let arg_tys' = case boxity of Unboxed -> drop arity arg_tys+ Boxed -> arg_tys+ ; tup_args1 <- tcTupArgs tup_args arg_tys'+ ; return $ mkHsWrapCo coi (ExplicitTuple x tup_args1 boxity) }++ | otherwise+ = -- The tup_args are a mixture of Present and Missing (for tuple sections)+ do { let arity = length tup_args++ ; arg_tys <- case boxity of+ { Boxed -> newFlexiTyVarTys arity liftedTypeKind+ ; Unboxed -> replicateM arity newOpenFlexiTyVarTy }++ -- Handle tuple sections where+ ; tup_args1 <- tcTupArgs tup_args arg_tys++ ; let expr' = ExplicitTuple x tup_args1 boxity+ missing_tys = [Scaled mult ty | (L _ (Missing (Scaled mult _)), ty) <- zip tup_args1 arg_tys]++ -- See Note [Linear fields generalization] in GHC.Tc.Gen.App+ act_res_ty+ = mkVisFunTys missing_tys (mkTupleTy1 boxity arg_tys)+ -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make++ ; traceTc "ExplicitTuple" (ppr act_res_ty $$ ppr res_ty)++ ; tcWrapResultMono expr expr' act_res_ty res_ty }++tcExpr (ExplicitSum _ alt arity expr) res_ty+ = do { let sum_tc = sumTyCon arity+ ; res_ty <- expTypeToType res_ty+ ; (coi, arg_tys) <- matchExpectedTyConApp sum_tc res_ty+ ; -- Drop levity vars, we don't care about them here+ let arg_tys' = drop arity arg_tys+ ; expr' <- tcCheckPolyExpr expr (arg_tys' `getNth` (alt - 1))+ ; return $ mkHsWrapCo coi (ExplicitSum arg_tys' alt arity expr' ) }++-- This will see the empty list only when -XOverloadedLists.+-- See Note [Empty lists] in GHC.Hs.Expr.+tcExpr (ExplicitList _ witness exprs) res_ty+ = case witness of+ Nothing -> do { res_ty <- expTypeToType res_ty+ ; (coi, elt_ty) <- matchExpectedListTy res_ty+ ; exprs' <- mapM (tc_elt elt_ty) exprs+ ; return $+ mkHsWrapCo coi $ ExplicitList elt_ty Nothing exprs' }++ Just fln -> do { ((exprs', elt_ty), fln')+ <- tcSyntaxOp ListOrigin fln+ [synKnownType intTy, SynList] res_ty $+ \ [elt_ty] [_int_mul, list_mul] ->+ -- We ignore _int_mul because the integer (first+ -- argument of fromListN) is statically known: it+ -- is desugared to a literal. Therefore there is+ -- no variable of which to scale the usage in that+ -- first argument, and `_int_mul` is completely+ -- free in this expression.+ do { exprs' <-+ mapM (tcScalingUsage list_mul . tc_elt elt_ty) exprs+ ; return (exprs', elt_ty) }++ ; return $ ExplicitList elt_ty (Just fln') exprs' }+ where tc_elt elt_ty expr = tcCheckPolyExpr expr elt_ty++{-+************************************************************************+* *+ Let, case, if, do+* *+************************************************************************+-}++tcExpr (HsLet x (L l binds) expr) res_ty+ = do { (binds', expr') <- tcLocalBinds binds $+ tcMonoExpr expr res_ty+ ; return (HsLet x (L l binds') expr') }++tcExpr (HsCase x scrut matches) res_ty+ = do { -- We used to typecheck the case alternatives first.+ -- The case patterns tend to give good type info to use+ -- when typechecking the scrutinee. For example+ -- case (map f) of+ -- (x:xs) -> ...+ -- will report that map is applied to too few arguments+ --+ -- But now, in the GADT world, we need to typecheck the scrutinee+ -- first, to get type info that may be refined in the case alternatives+ let mult = Many+ -- There is not yet syntax or inference mechanism for case+ -- expressions to be anything else than unrestricted.++ -- Typecheck the scrutinee. We use tcInferRho but tcInferSigma+ -- would also be possible (tcMatchesCase accepts sigma-types)+ -- Interesting litmus test: do these two behave the same?+ -- case id of {..}+ -- case (\v -> v) of {..}+ -- This design choice is discussed in #17790+ ; (scrut', scrut_ty) <- tcScalingUsage mult $ tcInferRho scrut++ ; traceTc "HsCase" (ppr scrut_ty)+ ; matches' <- tcMatchesCase match_ctxt (Scaled mult scrut_ty) matches res_ty+ ; return (HsCase x scrut' matches') }+ where+ match_ctxt = MC { mc_what = CaseAlt,+ mc_body = tcBody }++tcExpr (HsIf x pred b1 b2) res_ty+ = do { pred' <- tcCheckMonoExpr pred boolTy+ ; (u1,b1') <- tcCollectingUsage $ tcMonoExpr b1 res_ty+ ; (u2,b2') <- tcCollectingUsage $ tcMonoExpr b2 res_ty+ ; tcEmitBindingUsage (supUE u1 u2)+ ; return (HsIf x pred' b1' b2') }++tcExpr (HsMultiIf _ alts) res_ty+ = do { alts' <- mapM (wrapLocM $ tcGRHS match_ctxt res_ty) alts+ ; res_ty <- readExpType res_ty+ ; return (HsMultiIf res_ty alts') }+ where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }++tcExpr (HsDo _ do_or_lc stmts) res_ty+ = do { expr' <- tcDoStmts do_or_lc stmts res_ty+ ; return expr' }++tcExpr (HsProc x pat cmd) res_ty+ = do { (pat', cmd', coi) <- tcProc pat cmd res_ty+ ; return $ mkHsWrapCo coi (HsProc x pat' cmd') }++-- Typechecks the static form and wraps it with a call to 'fromStaticPtr'.+-- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable for an overview.+-- To type check+-- (static e) :: p a+-- we want to check (e :: a),+-- and wrap (static e) in a call to+-- fromStaticPtr :: IsStatic p => StaticPtr a -> p a++tcExpr (HsStatic fvs expr) res_ty+ = do { res_ty <- expTypeToType res_ty+ ; (co, (p_ty, expr_ty)) <- matchExpectedAppTy res_ty+ ; (expr', lie) <- captureConstraints $+ addErrCtxt (hang (text "In the body of a static form:")+ 2 (ppr expr)+ ) $+ tcCheckPolyExprNC expr expr_ty++ -- Check that the free variables of the static form are closed.+ -- It's OK to use nonDetEltsUniqSet here as the only side effects of+ -- checkClosedInStaticForm are error messages.+ ; mapM_ checkClosedInStaticForm $ nonDetEltsUniqSet fvs++ -- Require the type of the argument to be Typeable.+ -- The evidence is not used, but asking the constraint ensures that+ -- the current implementation is as restrictive as future versions+ -- of the StaticPointers extension.+ ; typeableClass <- tcLookupClass typeableClassName+ ; _ <- emitWantedEvVar StaticOrigin $+ mkTyConApp (classTyCon typeableClass)+ [liftedTypeKind, expr_ty]++ -- Insert the constraints of the static form in a global list for later+ -- validation.+ ; emitStaticConstraints lie++ -- Wrap the static form with the 'fromStaticPtr' call.+ ; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName+ [p_ty]+ ; let wrap = mkWpTyApps [expr_ty]+ ; loc <- getSrcSpanM+ ; return $ mkHsWrapCo co $ HsApp noExtField+ (L loc $ mkHsWrap wrap fromStaticPtr)+ (L loc (HsStatic fvs expr'))+ }++{-+************************************************************************+* *+ Record construction and update+* *+************************************************************************+-}++tcExpr expr@(RecordCon { rcon_con_name = L loc con_name+ , rcon_flds = rbinds }) res_ty+ = do { con_like <- tcLookupConLike con_name++ -- Check for missing fields+ ; checkMissingFields con_like rbinds++ ; (con_expr, con_sigma) <- tcInferId con_name+ ; (con_wrap, con_tau) <- topInstantiate orig con_sigma+ -- a shallow instantiation should really be enough for+ -- a data constructor.+ ; let arity = conLikeArity con_like+ Right (arg_tys, actual_res_ty) = tcSplitFunTysN arity con_tau+ ; case conLikeWrapId_maybe con_like of {+ Nothing -> nonBidirectionalErr (conLikeName con_like) ;+ Just con_id ->++ do { rbinds' <- tcRecordBinds con_like (map scaledThing arg_tys) rbinds+ -- It is currently not possible for a record to have+ -- multiplicities. When they do, `tcRecordBinds` will take+ -- scaled types instead. Meanwhile, it's safe to take+ -- `scaledThing` above, as we know all the multiplicities are+ -- Many.+ ; let rcon_tc = RecordConTc+ { rcon_con_like = con_like+ , rcon_con_expr = mkHsWrap con_wrap con_expr }+ expr' = RecordCon { rcon_ext = rcon_tc+ , rcon_con_name = L loc con_id+ , rcon_flds = rbinds' }++ ; tcWrapResultMono expr expr' actual_res_ty res_ty } } }+ where+ orig = OccurrenceOf con_name++{-+Note [Type of a record update]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The main complication with RecordUpd is that we need to explicitly+handle the *non-updated* fields. Consider:++ data T a b c = MkT1 { fa :: a, fb :: (b,c) }+ | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c }+ | MkT3 { fd :: a }++ upd :: T a b c -> (b',c) -> T a b' c+ upd t x = t { fb = x}++The result type should be (T a b' c)+not (T a b c), because 'b' *is not* mentioned in a non-updated field+not (T a b' c'), because 'c' *is* mentioned in a non-updated field+NB that it's not good enough to look at just one constructor; we must+look at them all; cf #3219++After all, upd should be equivalent to:+ upd t x = case t of+ MkT1 p q -> MkT1 p x+ MkT2 a b -> MkT2 p b+ MkT3 d -> error ...++So we need to give a completely fresh type to the result record,+and then constrain it by the fields that are *not* updated ("p" above).+We call these the "fixed" type variables, and compute them in getFixedTyVars.++Note that because MkT3 doesn't contain all the fields being updated,+its RHS is simply an error, so it doesn't impose any type constraints.+Hence the use of 'relevant_cont'.++Note [Implicit type sharing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+We also take into account any "implicit" non-update fields. For example+ data T a b where { MkT { f::a } :: T a a; ... }+So the "real" type of MkT is: forall ab. (a~b) => a -> T a b++Then consider+ upd t x = t { f=x }+We infer the type+ upd :: T a b -> a -> T a b+ upd (t::T a b) (x::a)+ = case t of { MkT (co:a~b) (_:a) -> MkT co x }+We can't give it the more general type+ upd :: T a b -> c -> T c b++Note [Criteria for update]+~~~~~~~~~~~~~~~~~~~~~~~~~~+We want to allow update for existentials etc, provided the updated+field isn't part of the existential. For example, this should be ok.+ data T a where { MkT { f1::a, f2::b->b } :: T a }+ f :: T a -> b -> T b+ f t b = t { f1=b }++The criterion we use is this:++ The types of the updated fields+ mention only the universally-quantified type variables+ of the data constructor++NB: this is not (quite) the same as being a "naughty" record selector+(See Note [Naughty record selectors]) in GHC.Tc.TyCl), at least+in the case of GADTs. Consider+ data T a where { MkT :: { f :: a } :: T [a] }+Then f is not "naughty" because it has a well-typed record selector.+But we don't allow updates for 'f'. (One could consider trying to+allow this, but it makes my head hurt. Badly. And no one has asked+for it.)++In principle one could go further, and allow+ g :: T a -> T a+ g t = t { f2 = \x -> x }+because the expression is polymorphic...but that seems a bridge too far.++Note [Data family example]+~~~~~~~~~~~~~~~~~~~~~~~~~~+ data instance T (a,b) = MkT { x::a, y::b }+ --->+ data :TP a b = MkT { a::a, y::b }+ coTP a b :: T (a,b) ~ :TP a b++Suppose r :: T (t1,t2), e :: t3+Then r { x=e } :: T (t3,t1)+ --->+ case r |> co1 of+ MkT x y -> MkT e y |> co2+ where co1 :: T (t1,t2) ~ :TP t1 t2+ co2 :: :TP t3 t2 ~ T (t3,t2)+The wrapping with co2 is done by the constructor wrapper for MkT++Outgoing invariants+~~~~~~~~~~~~~~~~~~~+In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys):++ * cons are the data constructors to be updated++ * in_inst_tys, out_inst_tys have same length, and instantiate the+ *representation* tycon of the data cons. In Note [Data+ family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2]++Note [Mixed Record Field Updates]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following pattern synonym.++ data MyRec = MyRec { foo :: Int, qux :: String }++ pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2}++This allows updates such as the following++ updater :: MyRec -> MyRec+ updater a = a {f1 = 1 }++It would also make sense to allow the following update (which we reject).++ updater a = a {f1 = 1, qux = "two" } ==? MyRec 1 "two"++This leads to confusing behaviour when the selectors in fact refer the same+field.++ updater a = a {f1 = 1, foo = 2} ==? ???++For this reason, we reject a mixture of pattern synonym and normal record+selectors in the same update block. Although of course we still allow the+following.++ updater a = (a {f1 = 1}) {foo = 2}++ > updater (MyRec 0 "str")+ MyRec 2 "str"++-}++tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty+ = ASSERT( notNull rbnds )+ do { -- STEP -2: typecheck the record_expr, the record to be updated+ (record_expr', record_rho) <- tcScalingUsage Many $ tcInferRho record_expr+ -- Record update drops some of the content of the record (namely the+ -- content of the field being updated). As a consequence, unless the+ -- field being updated is unrestricted in the record, or we need an+ -- unrestricted record. Currently, we simply always require an+ -- unrestricted record.+ --+ -- Consider the following example:+ --+ -- data R a = R { self :: a }+ -- bad :: a ⊸ ()+ -- bad x = let r = R x in case r { self = () } of { R x' -> x' }+ --+ -- This should definitely *not* typecheck.++ -- STEP -1 See Note [Disambiguating record fields] in GHC.Tc.Gen.Head+ -- After this we know that rbinds is unambiguous+ ; rbinds <- disambiguateRecordBinds record_expr record_rho rbnds res_ty+ ; let upd_flds = map (unLoc . hsRecFieldLbl . unLoc) rbinds+ upd_fld_occs = map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds+ sel_ids = map selectorAmbiguousFieldOcc upd_flds+ -- STEP 0+ -- Check that the field names are really field names+ -- and they are all field names for proper records or+ -- all field names for pattern synonyms.+ ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name)+ | fld <- rbinds,+ -- Excludes class ops+ let L loc sel_id = hsRecUpdFieldId (unLoc fld),+ not (isRecordSelector sel_id),+ let fld_name = idName sel_id ]+ ; unless (null bad_guys) (sequence bad_guys >> failM)+ -- See note [Mixed Record Selectors]+ ; let (data_sels, pat_syn_sels) =+ partition isDataConRecordSelector sel_ids+ ; MASSERT( all isPatSynRecordSelector pat_syn_sels )+ ; checkTc ( null data_sels || null pat_syn_sels )+ ( mixedSelectors data_sels pat_syn_sels )++ -- STEP 1+ -- Figure out the tycon and data cons from the first field name+ ; let -- It's OK to use the non-tc splitters here (for a selector)+ sel_id : _ = sel_ids++ mtycon :: Maybe TyCon+ mtycon = case idDetails sel_id of+ RecSelId (RecSelData tycon) _ -> Just tycon+ _ -> Nothing++ con_likes :: [ConLike]+ con_likes = case idDetails sel_id of+ RecSelId (RecSelData tc) _+ -> map RealDataCon (tyConDataCons tc)+ RecSelId (RecSelPatSyn ps) _+ -> [PatSynCon ps]+ _ -> panic "tcRecordUpd"+ -- NB: for a data type family, the tycon is the instance tycon++ relevant_cons = conLikesWithFields con_likes upd_fld_occs+ -- A constructor is only relevant to this process if+ -- it contains *all* the fields that are being updated+ -- Other ones will cause a runtime error if they occur++ -- Step 2+ -- Check that at least one constructor has all the named fields+ -- i.e. has an empty set of bad fields returned by badFields+ ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds con_likes)++ -- Take apart a representative constructor+ ; let con1 = ASSERT( not (null relevant_cons) ) head relevant_cons+ (con1_tvs, _, _, _prov_theta, req_theta, scaled_con1_arg_tys, _)+ = conLikeFullSig con1+ con1_arg_tys = map scaledThing scaled_con1_arg_tys+ -- We can safely drop the fields' multiplicities because+ -- they are currently always 1: there is no syntax for record+ -- fields with other multiplicities yet. This way we don't need+ -- to handle it in the rest of the function+ con1_flds = map flLabel $ conLikeFieldLabels con1+ con1_tv_tys = mkTyVarTys con1_tvs+ con1_res_ty = case mtycon of+ Just tc -> mkFamilyTyConApp tc con1_tv_tys+ Nothing -> conLikeResTy con1 con1_tv_tys++ -- Check that we're not dealing with a unidirectional pattern+ -- synonym+ ; unless (isJust $ conLikeWrapId_maybe con1)+ (nonBidirectionalErr (conLikeName con1))++ -- STEP 3 Note [Criteria for update]+ -- Check that each updated field is polymorphic; that is, its type+ -- mentions only the universally-quantified variables of the data con+ ; let flds1_w_tys = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys+ bad_upd_flds = filter bad_fld flds1_w_tys+ con1_tv_set = mkVarSet con1_tvs+ bad_fld (fld, ty) = fld `elem` upd_fld_occs &&+ not (tyCoVarsOfType ty `subVarSet` con1_tv_set)+ ; checkTc (null bad_upd_flds) (badFieldTypes bad_upd_flds)++ -- STEP 4 Note [Type of a record update]+ -- Figure out types for the scrutinee and result+ -- Both are of form (T a b c), with fresh type variables, but with+ -- common variables where the scrutinee and result must have the same type+ -- These are variables that appear in *any* arg of *any* of the+ -- relevant constructors *except* in the updated fields+ --+ ; let fixed_tvs = getFixedTyVars upd_fld_occs con1_tvs relevant_cons+ is_fixed_tv tv = tv `elemVarSet` fixed_tvs++ mk_inst_ty :: TCvSubst -> (TyVar, TcType) -> TcM (TCvSubst, TcType)+ -- Deals with instantiation of kind variables+ -- c.f. GHC.Tc.Utils.TcMType.newMetaTyVars+ mk_inst_ty subst (tv, result_inst_ty)+ | is_fixed_tv tv -- Same as result type+ = return (extendTvSubst subst tv result_inst_ty, result_inst_ty)+ | otherwise -- Fresh type, of correct kind+ = do { (subst', new_tv) <- newMetaTyVarX subst tv+ ; return (subst', mkTyVarTy new_tv) }++ ; (result_subst, con1_tvs') <- newMetaTyVars con1_tvs+ ; let result_inst_tys = mkTyVarTys con1_tvs'+ init_subst = mkEmptyTCvSubst (getTCvInScope result_subst)++ ; (scrut_subst, scrut_inst_tys) <- mapAccumLM mk_inst_ty init_subst+ (con1_tvs `zip` result_inst_tys)++ ; let rec_res_ty = TcType.substTy result_subst con1_res_ty+ scrut_ty = TcType.substTy scrut_subst con1_res_ty+ con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys++ ; co_scrut <- unifyType (Just (ppr record_expr)) record_rho scrut_ty+ -- NB: normal unification is OK here (as opposed to subsumption),+ -- because for this to work out, both record_rho and scrut_ty have+ -- to be normal datatypes -- no contravariant stuff can go on++ -- STEP 5+ -- Typecheck the bindings+ ; rbinds' <- tcRecordUpd con1 con1_arg_tys' rbinds++ -- STEP 6: Deal with the stupid theta+ ; let theta' = substThetaUnchecked scrut_subst (conLikeStupidTheta con1)+ ; instStupidTheta RecordUpdOrigin theta'++ -- Step 7: make a cast for the scrutinee, in the+ -- case that it's from a data family+ ; let fam_co :: HsWrapper -- RepT t1 .. tn ~R scrut_ty+ fam_co | Just tycon <- mtycon+ , Just co_con <- tyConFamilyCoercion_maybe tycon+ = mkWpCastR (mkTcUnbranchedAxInstCo co_con scrut_inst_tys [])+ | otherwise+ = idHsWrapper++ -- Step 8: Check that the req constraints are satisfied+ -- For normal data constructors req_theta is empty but we must do+ -- this check for pattern synonyms.+ ; let req_theta' = substThetaUnchecked scrut_subst req_theta+ ; req_wrap <- instCallConstraints RecordUpdOrigin req_theta'++ -- Phew!+ ; let upd_tc = RecordUpdTc { rupd_cons = relevant_cons+ , rupd_in_tys = scrut_inst_tys+ , rupd_out_tys = result_inst_tys+ , rupd_wrap = req_wrap }+ expr' = RecordUpd { rupd_expr = mkLHsWrap fam_co $+ mkLHsWrapCo co_scrut record_expr'+ , rupd_flds = rbinds'+ , rupd_ext = upd_tc }++ ; tcWrapResult expr expr' rec_res_ty res_ty }+++{-+************************************************************************+* *+ Arithmetic sequences e.g. [a,b..]+ and their parallel-array counterparts e.g. [: a,b.. :]++* *+************************************************************************+-}++tcExpr (ArithSeq _ witness seq) res_ty+ = tcArithSeq witness seq res_ty++{-+************************************************************************+* *+ Template Haskell+* *+************************************************************************+-}++-- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceExpr'.+-- Here we get rid of it and add the finalizers to the global environment.+--+-- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice.+tcExpr (HsSpliceE _ (HsSpliced _ mod_finalizers (HsSplicedExpr expr)))+ res_ty+ = do addModFinalizersWithLclEnv mod_finalizers+ tcExpr expr res_ty+tcExpr (HsSpliceE _ splice) res_ty = tcSpliceExpr splice res_ty+tcExpr e@(HsBracket _ brack) res_ty = tcTypedBracket e brack res_ty+tcExpr e@(HsRnBracketOut _ brack ps) res_ty = tcUntypedBracket e brack ps res_ty++{-+************************************************************************+* *+ Rebindable syntax+* *+************************************************************************+-}++-- See Note [Rebindable syntax and HsExpansion].+tcExpr (XExpr (HsExpanded a b)) t+ = fmap (XExpr . ExpansionExpr . HsExpanded a) $+ setSrcSpan generatedSrcSpan (tcExpr b t)++{-+************************************************************************+* *+ Catch-all+* *+************************************************************************+-}++tcExpr other _ = pprPanic "tcExpr" (ppr other)+ -- Include ArrForm, ArrApp, which shouldn't appear at all+ -- Also HsTcBracketOut, HsQuasiQuoteE+++{-+************************************************************************+* *+ Arithmetic sequences [a..b] etc+* *+************************************************************************+-}++tcArithSeq :: Maybe (SyntaxExpr GhcRn) -> ArithSeqInfo GhcRn -> ExpRhoType+ -> TcM (HsExpr GhcTc)++tcArithSeq witness seq@(From expr) res_ty+ = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty+ ; expr' <-tcScalingUsage elt_mult $ tcCheckPolyExpr expr elt_ty+ ; enum_from <- newMethodFromName (ArithSeqOrigin seq)+ enumFromName [elt_ty]+ ; return $ mkHsWrap wrap $+ ArithSeq enum_from wit' (From expr') }++tcArithSeq witness seq@(FromThen expr1 expr2) res_ty+ = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty+ ; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty+ ; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty+ ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)+ enumFromThenName [elt_ty]+ ; return $ mkHsWrap wrap $+ ArithSeq enum_from_then wit' (FromThen expr1' expr2') }++tcArithSeq witness seq@(FromTo expr1 expr2) res_ty+ = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty+ ; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty+ ; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty+ ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)+ enumFromToName [elt_ty]+ ; return $ mkHsWrap wrap $+ ArithSeq enum_from_to wit' (FromTo expr1' expr2') }++tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty+ = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty+ ; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty+ ; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty+ ; expr3' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr3 elt_ty+ ; eft <- newMethodFromName (ArithSeqOrigin seq)+ enumFromThenToName [elt_ty]+ ; return $ mkHsWrap wrap $+ ArithSeq eft wit' (FromThenTo expr1' expr2' expr3') }++-----------------+arithSeqEltType :: Maybe (SyntaxExpr GhcRn) -> ExpRhoType+ -> TcM (HsWrapper, Mult, TcType, Maybe (SyntaxExpr GhcTc))+arithSeqEltType Nothing res_ty+ = do { res_ty <- expTypeToType res_ty+ ; (coi, elt_ty) <- matchExpectedListTy res_ty+ ; return (mkWpCastN coi, One, elt_ty, Nothing) }+arithSeqEltType (Just fl) res_ty+ = do { ((elt_mult, elt_ty), fl')+ <- tcSyntaxOp ListOrigin fl [SynList] res_ty $+ \ [elt_ty] [elt_mult] -> return (elt_mult, elt_ty)+ ; return (idHsWrapper, elt_mult, elt_ty, Just fl') }++----------------+tcTupArgs :: [LHsTupArg GhcRn] -> [TcSigmaType] -> TcM [LHsTupArg GhcTc]+tcTupArgs args tys+ = ASSERT( equalLength args tys ) mapM go (args `zip` tys)+ where+ go (L l (Missing {}), arg_ty) = do { mult <- newFlexiTyVarTy multiplicityTy+ ; return (L l (Missing (Scaled mult arg_ty))) }+ go (L l (Present x expr), arg_ty) = do { expr' <- tcCheckPolyExpr expr arg_ty+ ; return (L l (Present x expr')) }++---------------------------+-- See TcType.SyntaxOpType also for commentary+tcSyntaxOp :: CtOrigin+ -> SyntaxExprRn+ -> [SyntaxOpType] -- ^ shape of syntax operator arguments+ -> ExpRhoType -- ^ overall result type+ -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ Type check any arguments,+ -- takes a type per hole and a+ -- multiplicity per arrow in+ -- the shape.+ -> TcM (a, SyntaxExprTc)+-- ^ Typecheck a syntax operator+-- The operator is a variable or a lambda at this stage (i.e. renamer+-- output)t+tcSyntaxOp orig expr arg_tys res_ty+ = tcSyntaxOpGen orig expr arg_tys (SynType res_ty)++-- | Slightly more general version of 'tcSyntaxOp' that allows the caller+-- to specify the shape of the result of the syntax operator+tcSyntaxOpGen :: CtOrigin+ -> SyntaxExprRn+ -> [SyntaxOpType]+ -> SyntaxOpType+ -> ([TcSigmaType] -> [Mult] -> TcM a)+ -> TcM (a, SyntaxExprTc)+tcSyntaxOpGen orig (SyntaxExprRn op) arg_tys res_ty thing_inside+ = do { (expr, sigma) <- tcInferAppHead op [] Nothing+ -- Nothing here might be improved, but all this+ -- code is scheduled for demolition anyway+ ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma)+ ; (result, expr_wrap, arg_wraps, res_wrap)+ <- tcSynArgA orig sigma arg_tys res_ty $+ thing_inside+ ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma )+ ; return (result, SyntaxExprTc { syn_expr = mkHsWrap expr_wrap expr+ , syn_arg_wraps = arg_wraps+ , syn_res_wrap = res_wrap }) }+tcSyntaxOpGen _ NoSyntaxExprRn _ _ _ = panic "tcSyntaxOpGen"++{-+Note [tcSynArg]+~~~~~~~~~~~~~~~+Because of the rich structure of SyntaxOpType, we must do the+contra-/covariant thing when working down arrows, to get the+instantiation vs. skolemisation decisions correct (and, more+obviously, the orientation of the HsWrappers). We thus have+two tcSynArgs.+-}++-- works on "expected" types, skolemising where necessary+-- See Note [tcSynArg]+tcSynArgE :: CtOrigin+ -> TcSigmaType+ -> SyntaxOpType -- ^ shape it is expected to have+ -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ check the arguments+ -> TcM (a, HsWrapper)+ -- ^ returns a wrapper :: (type of right shape) "->" (type passed in)+tcSynArgE orig sigma_ty syn_ty thing_inside+ = do { (skol_wrap, (result, ty_wrapper))+ <- tcSkolemise GenSigCtxt sigma_ty $ \ rho_ty ->+ go rho_ty syn_ty+ ; return (result, skol_wrap <.> ty_wrapper) }+ where+ go rho_ty SynAny+ = do { result <- thing_inside [rho_ty] []+ ; return (result, idHsWrapper) }++ go rho_ty SynRho -- same as SynAny, because we skolemise eagerly+ = do { result <- thing_inside [rho_ty] []+ ; return (result, idHsWrapper) }++ go rho_ty SynList+ = do { (list_co, elt_ty) <- matchExpectedListTy rho_ty+ ; result <- thing_inside [elt_ty] []+ ; return (result, mkWpCastN list_co) }++ go rho_ty (SynFun arg_shape res_shape)+ = do { ( match_wrapper -- :: (arg_ty -> res_ty) "->" rho_ty+ , ( ( (result, arg_ty, res_ty, op_mult)+ , res_wrapper ) -- :: res_ty_out "->" res_ty+ , arg_wrapper1, [], arg_wrapper2 ) ) -- :: arg_ty "->" arg_ty_out+ <- matchExpectedFunTys herald GenSigCtxt 1 (mkCheckExpType rho_ty) $+ \ [arg_ty] res_ty ->+ do { arg_tc_ty <- expTypeToType (scaledThing arg_ty)+ ; res_tc_ty <- expTypeToType res_ty++ -- another nested arrow is too much for now,+ -- but I bet we'll never need this+ ; MASSERT2( case arg_shape of+ SynFun {} -> False;+ _ -> True+ , text "Too many nested arrows in SyntaxOpType" $$+ pprCtOrigin orig )++ ; let arg_mult = scaledMult arg_ty+ ; tcSynArgA orig arg_tc_ty [] arg_shape $+ \ arg_results arg_res_mults ->+ tcSynArgE orig res_tc_ty res_shape $+ \ res_results res_res_mults ->+ do { result <- thing_inside (arg_results ++ res_results) ([arg_mult] ++ arg_res_mults ++ res_res_mults)+ ; return (result, arg_tc_ty, res_tc_ty, arg_mult) }}++ ; return ( result+ , match_wrapper <.>+ mkWpFun (arg_wrapper2 <.> arg_wrapper1) res_wrapper+ (Scaled op_mult arg_ty) res_ty doc ) }+ where+ herald = text "This rebindable syntax expects a function with"+ doc = text "When checking a rebindable syntax operator arising from" <+> ppr orig++ go rho_ty (SynType the_ty)+ = do { wrap <- tcSubTypePat orig GenSigCtxt the_ty rho_ty+ ; result <- thing_inside [] []+ ; return (result, wrap) }++-- works on "actual" types, instantiating where necessary+-- See Note [tcSynArg]+tcSynArgA :: CtOrigin+ -> TcSigmaType+ -> [SyntaxOpType] -- ^ argument shapes+ -> SyntaxOpType -- ^ result shape+ -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ check the arguments+ -> TcM (a, HsWrapper, [HsWrapper], HsWrapper)+ -- ^ returns a wrapper to be applied to the original function,+ -- wrappers to be applied to arguments+ -- and a wrapper to be applied to the overall expression+tcSynArgA orig sigma_ty arg_shapes res_shape thing_inside+ = do { (match_wrapper, arg_tys, res_ty)+ <- matchActualFunTysRho herald orig Nothing+ (length arg_shapes) sigma_ty+ -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty)+ ; ((result, res_wrapper), arg_wrappers)+ <- tc_syn_args_e (map scaledThing arg_tys) arg_shapes $ \ arg_results arg_res_mults ->+ tc_syn_arg res_ty res_shape $ \ res_results ->+ thing_inside (arg_results ++ res_results) (map scaledMult arg_tys ++ arg_res_mults)+ ; return (result, match_wrapper, arg_wrappers, res_wrapper) }+ where+ herald = text "This rebindable syntax expects a function with"++ tc_syn_args_e :: [TcSigmaType] -> [SyntaxOpType]+ -> ([TcSigmaType] -> [Mult] -> TcM a)+ -> TcM (a, [HsWrapper])+ -- the wrappers are for arguments+ tc_syn_args_e (arg_ty : arg_tys) (arg_shape : arg_shapes) thing_inside+ = do { ((result, arg_wraps), arg_wrap)+ <- tcSynArgE orig arg_ty arg_shape $ \ arg1_results arg1_mults ->+ tc_syn_args_e arg_tys arg_shapes $ \ args_results args_mults ->+ thing_inside (arg1_results ++ args_results) (arg1_mults ++ args_mults)+ ; return (result, arg_wrap : arg_wraps) }+ tc_syn_args_e _ _ thing_inside = (, []) <$> thing_inside [] []++ tc_syn_arg :: TcSigmaType -> SyntaxOpType+ -> ([TcSigmaType] -> TcM a)+ -> TcM (a, HsWrapper)+ -- the wrapper applies to the overall result+ tc_syn_arg res_ty SynAny thing_inside+ = do { result <- thing_inside [res_ty]+ ; return (result, idHsWrapper) }+ tc_syn_arg res_ty SynRho thing_inside+ = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty+ -- inst_wrap :: res_ty "->" rho_ty+ ; result <- thing_inside [rho_ty]+ ; return (result, inst_wrap) }+ tc_syn_arg res_ty SynList thing_inside+ = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty+ -- inst_wrap :: res_ty "->" rho_ty+ ; (list_co, elt_ty) <- matchExpectedListTy rho_ty+ -- list_co :: [elt_ty] ~N rho_ty+ ; result <- thing_inside [elt_ty]+ ; return (result, mkWpCastN (mkTcSymCo list_co) <.> inst_wrap) }+ tc_syn_arg _ (SynFun {}) _+ = pprPanic "tcSynArgA hits a SynFun" (ppr orig)+ tc_syn_arg res_ty (SynType the_ty) thing_inside+ = do { wrap <- tcSubType orig GenSigCtxt res_ty the_ty+ ; result <- thing_inside []+ ; return (result, wrap) }++{-+Note [Push result type in]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Unify with expected result before type-checking the args so that the+info from res_ty percolates to args. This is when we might detect a+too-few args situation. (One can think of cases when the opposite+order would give a better error message.)+experimenting with putting this first.++Here's an example where it actually makes a real difference++ class C t a b | t a -> b+ instance C Char a Bool++ data P t a = forall b. (C t a b) => MkP b+ data Q t = MkQ (forall a. P t a)++ f1, f2 :: Q Char;+ f1 = MkQ (MkP True)+ f2 = MkQ (MkP True :: forall a. P Char a)++With the change, f1 will type-check, because the 'Char' info from+the signature is propagated into MkQ's argument. With the check+in the other order, the extra signature in f2 is reqd.+-}++{- *********************************************************************+* *+ Record bindings+* *+********************************************************************* -}++getFixedTyVars :: [FieldLabelString] -> [TyVar] -> [ConLike] -> TyVarSet+-- These tyvars must not change across the updates+getFixedTyVars upd_fld_occs univ_tvs cons+ = mkVarSet [tv1 | con <- cons+ , let (u_tvs, _, eqspec, prov_theta+ , req_theta, arg_tys, _)+ = conLikeFullSig con+ theta = eqSpecPreds eqspec+ ++ prov_theta+ ++ req_theta+ flds = conLikeFieldLabels con+ fixed_tvs = exactTyCoVarsOfTypes (map scaledThing fixed_tys)+ -- fixed_tys: See Note [Type of a record update]+ `unionVarSet` tyCoVarsOfTypes theta+ -- Universally-quantified tyvars that+ -- appear in any of the *implicit*+ -- arguments to the constructor are fixed+ -- See Note [Implicit type sharing]++ fixed_tys = [ty | (fl, ty) <- zip flds arg_tys+ , not (flLabel fl `elem` upd_fld_occs)]+ , (tv1,tv) <- univ_tvs `zip` u_tvs+ , tv `elemVarSet` fixed_tvs ]+++-- Disambiguate the fields in a record update.+-- See Note [Disambiguating record fields] in GHC.Tc.Gen.Head+disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType+ -> [LHsRecUpdField GhcRn] -> ExpRhoType+ -> TcM [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]+disambiguateRecordBinds record_expr record_rho rbnds res_ty+ -- Are all the fields unambiguous?+ = case mapM isUnambiguous rbnds of+ -- If so, just skip to looking up the Ids+ -- Always the case if DuplicateRecordFields is off+ Just rbnds' -> mapM lookupSelector rbnds'+ Nothing -> -- If not, try to identify a single parent+ do { fam_inst_envs <- tcGetFamInstEnvs+ -- Look up the possible parents for each field+ ; rbnds_with_parents <- getUpdFieldsParents+ ; let possible_parents = map (map fst . snd) rbnds_with_parents+ -- Identify a single parent+ ; p <- identifyParent fam_inst_envs possible_parents+ -- Pick the right selector with that parent for each field+ ; checkNoErrs $ mapM (pickParent p) rbnds_with_parents }+ where+ -- Extract the selector name of a field update if it is unambiguous+ isUnambiguous :: LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn,Name)+ isUnambiguous x = case unLoc (hsRecFieldLbl (unLoc x)) of+ Unambiguous sel_name _ -> Just (x, sel_name)+ Ambiguous{} -> Nothing++ -- Look up the possible parents and selector GREs for each field+ getUpdFieldsParents :: TcM [(LHsRecUpdField GhcRn+ , [(RecSelParent, GlobalRdrElt)])]+ getUpdFieldsParents+ = fmap (zip rbnds) $ mapM+ (lookupParents . unLoc . hsRecUpdFieldRdr . unLoc)+ rbnds++ -- Given a the lists of possible parents for each field,+ -- identify a single parent+ identifyParent :: FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent+ identifyParent fam_inst_envs possible_parents+ = case foldr1 intersect possible_parents of+ -- No parents for all fields: record update is ill-typed+ [] -> failWithTc (noPossibleParents rbnds)++ -- Exactly one datatype with all the fields: use that+ [p] -> return p++ -- Multiple possible parents: try harder to disambiguate+ -- Can we get a parent TyCon from the pushed-in type?+ _:_ | Just p <- tyConOfET fam_inst_envs res_ty -> return (RecSelData p)++ -- Does the expression being updated have a type signature?+ -- If so, try to extract a parent TyCon from it+ | Just {} <- obviousSig (unLoc record_expr)+ , Just tc <- tyConOf fam_inst_envs record_rho+ -> return (RecSelData tc)++ -- Nothing else we can try...+ _ -> failWithTc badOverloadedUpdate++ -- Make a field unambiguous by choosing the given parent.+ -- Emits an error if the field cannot have that parent,+ -- e.g. if the user writes+ -- r { x = e } :: T+ -- where T does not have field x.+ pickParent :: RecSelParent+ -> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])+ -> TcM (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))+ pickParent p (upd, xs)+ = case lookup p xs of+ -- Phew! The parent is valid for this field.+ -- Previously ambiguous fields must be marked as+ -- used now that we know which one is meant, but+ -- unambiguous ones shouldn't be recorded again+ -- (giving duplicate deprecation warnings).+ Just gre -> do { unless (null (tail xs)) $ do+ let L loc _ = hsRecFieldLbl (unLoc upd)+ setSrcSpan loc $ addUsedGRE True gre+ ; lookupSelector (upd, gre_name gre) }+ -- The field doesn't belong to this parent, so report+ -- an error but keep going through all the fields+ Nothing -> do { addErrTc (fieldNotInType p+ (unLoc (hsRecUpdFieldRdr (unLoc upd))))+ ; lookupSelector (upd, gre_name (snd (head xs))) }++ -- Given a (field update, selector name) pair, look up the+ -- selector to give a field update with an unambiguous Id+ lookupSelector :: (LHsRecUpdField GhcRn, Name)+ -> TcM (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))+ lookupSelector (L l upd, n)+ = do { i <- tcLookupId n+ ; let L loc af = hsRecFieldLbl upd+ lbl = rdrNameAmbiguousFieldOcc af+ ; return $ L l upd { hsRecFieldLbl+ = L loc (Unambiguous i (L loc lbl)) } }+++{-+Game plan for record bindings+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+1. Find the TyCon for the bindings, from the first field label.++2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.++For each binding field = value++3. Instantiate the field type (from the field label) using the type+ envt from step 2.++4 Type check the value using tcValArg, passing the field type as+ the expected argument type.++This extends OK when the field types are universally quantified.+-}++tcRecordBinds+ :: ConLike+ -> [TcType] -- Expected type for each field+ -> HsRecordBinds GhcRn+ -> TcM (HsRecordBinds GhcTc)++tcRecordBinds con_like arg_tys (HsRecFields rbinds dd)+ = do { mb_binds <- mapM do_bind rbinds+ ; return (HsRecFields (catMaybes mb_binds) dd) }+ where+ fields = map flSelector $ conLikeFieldLabels con_like+ flds_w_tys = zipEqual "tcRecordBinds" fields arg_tys++ do_bind :: LHsRecField GhcRn (LHsExpr GhcRn)+ -> TcM (Maybe (LHsRecField GhcTc (LHsExpr GhcTc)))+ do_bind (L l fld@(HsRecField { hsRecFieldLbl = f+ , hsRecFieldArg = rhs }))++ = do { mb <- tcRecordField con_like flds_w_tys f rhs+ ; case mb of+ Nothing -> return Nothing+ Just (f', rhs') -> return (Just (L l (fld { hsRecFieldLbl = f'+ , hsRecFieldArg = rhs' }))) }++tcRecordUpd+ :: ConLike+ -> [TcType] -- Expected type for each field+ -> [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]+ -> TcM [LHsRecUpdField GhcTc]++tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds+ where+ fields = map flSelector $ conLikeFieldLabels con_like+ flds_w_tys = zipEqual "tcRecordUpd" fields arg_tys++ do_bind :: LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)+ -> TcM (Maybe (LHsRecUpdField GhcTc))+ do_bind (L l fld@(HsRecField { hsRecFieldLbl = L loc af+ , hsRecFieldArg = rhs }))+ = do { let lbl = rdrNameAmbiguousFieldOcc af+ sel_id = selectorAmbiguousFieldOcc af+ f = L loc (FieldOcc (idName sel_id) (L loc lbl))+ ; mb <- tcRecordField con_like flds_w_tys f rhs+ ; case mb of+ Nothing -> return Nothing+ Just (f', rhs') ->+ return (Just+ (L l (fld { hsRecFieldLbl+ = L loc (Unambiguous+ (extFieldOcc (unLoc f'))+ (L loc lbl))+ , hsRecFieldArg = rhs' }))) }++tcRecordField :: ConLike -> Assoc Name Type+ -> LFieldOcc GhcRn -> LHsExpr GhcRn+ -> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))+tcRecordField con_like flds_w_tys (L loc (FieldOcc sel_name lbl)) rhs+ | Just field_ty <- assocMaybe flds_w_tys sel_name+ = addErrCtxt (fieldCtxt field_lbl) $+ do { rhs' <- tcCheckPolyExprNC rhs field_ty+ ; let field_id = mkUserLocal (nameOccName sel_name)+ (nameUnique sel_name)+ Many field_ty loc+ -- Yuk: the field_id has the *unique* of the selector Id+ -- (so we can find it easily)+ -- but is a LocalId with the appropriate type of the RHS+ -- (so the desugarer knows the type of local binder to make)+ ; return (Just (L loc (FieldOcc field_id lbl), rhs')) }+ | otherwise+ = do { addErrTc (badFieldCon con_like field_lbl)+ ; return Nothing }+ where+ field_lbl = occNameFS $ rdrNameOcc (unLoc lbl)+++checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> TcM ()+checkMissingFields con_like rbinds+ | null field_labels -- Not declared as a record;+ -- But C{} is still valid if no strict fields+ = if any isBanged field_strs then+ -- Illegal if any arg is strict+ addErrTc (missingStrictFields con_like [])+ else do+ warn <- woptM Opt_WarnMissingFields+ when (warn && notNull field_strs && null field_labels)+ (warnTc (Reason Opt_WarnMissingFields) True+ (missingFields con_like []))++ | otherwise = do -- A record+ unless (null missing_s_fields)+ (addErrTc (missingStrictFields con_like missing_s_fields))++ warn <- woptM Opt_WarnMissingFields+ when (warn && notNull missing_ns_fields)+ (warnTc (Reason Opt_WarnMissingFields) True+ (missingFields con_like missing_ns_fields))++ where+ missing_s_fields+ = [ flLabel fl | (fl, str) <- field_info,+ isBanged str,+ not (fl `elemField` field_names_used)+ ]+ missing_ns_fields+ = [ flLabel fl | (fl, str) <- field_info,+ not (isBanged str),+ not (fl `elemField` field_names_used)+ ]++ field_names_used = hsRecFields rbinds+ field_labels = conLikeFieldLabels con_like++ field_info = zipEqual "missingFields"+ field_labels+ field_strs++ field_strs = conLikeImplBangs con_like++ fl `elemField` flds = any (\ fl' -> flSelector fl == fl') flds++{-+************************************************************************+* *+\subsection{Errors and contexts}+* *+************************************************************************++Boring and alphabetical:+-}++fieldCtxt :: FieldLabelString -> SDoc+fieldCtxt field_name+ = text "In the" <+> quotes (ppr field_name) <+> ptext (sLit "field of a record")++mk_op_msg :: LHsExpr GhcRn -> SDoc+mk_op_msg op = text "The operator" <+> quotes (ppr op) <+> text "takes"++badFieldTypes :: [(FieldLabelString,TcType)] -> SDoc+badFieldTypes prs+ = hang (text "Record update for insufficiently polymorphic field"+ <> plural prs <> colon)+ 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ])++badFieldsUpd+ :: [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]+ -- Field names that don't belong to a single datacon+ -> [ConLike] -- Data cons of the type which the first field name belongs to+ -> SDoc+badFieldsUpd rbinds data_cons+ = hang (text "No constructor has all these fields:")+ 2 (pprQuotedList conflictingFields)+ -- See Note [Finding the conflicting fields]+ where+ -- A (preferably small) set of fields such that no constructor contains+ -- all of them. See Note [Finding the conflicting fields]+ conflictingFields = case nonMembers of+ -- nonMember belongs to a different type.+ (nonMember, _) : _ -> [aMember, nonMember]+ [] -> let+ -- All of rbinds belong to one type. In this case, repeatedly add+ -- a field to the set until no constructor contains the set.++ -- Each field, together with a list indicating which constructors+ -- have all the fields so far.+ growingSets :: [(FieldLabelString, [Bool])]+ growingSets = scanl1 combine membership+ combine (_, setMem) (field, fldMem)+ = (field, zipWith (&&) setMem fldMem)+ in+ -- Fields that don't change the membership status of the set+ -- are redundant and can be dropped.+ map (fst . head) $ groupBy ((==) `on` snd) growingSets++ aMember = ASSERT( not (null members) ) fst (head members)+ (members, nonMembers) = partition (or . snd) membership++ -- For each field, which constructors contain the field?+ membership :: [(FieldLabelString, [Bool])]+ membership = sortMembership $+ map (\fld -> (fld, map (fld `elementOfUniqSet`) fieldLabelSets)) $+ map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) rbinds++ fieldLabelSets :: [UniqSet FieldLabelString]+ fieldLabelSets = map (mkUniqSet . map flLabel . conLikeFieldLabels) data_cons++ -- Sort in order of increasing number of True, so that a smaller+ -- conflicting set can be found.+ sortMembership =+ map snd .+ sortBy (compare `on` fst) .+ map (\ item@(_, membershipRow) -> (countTrue membershipRow, item))++ countTrue = count id++{-+Note [Finding the conflicting fields]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+ data A = A {a0, a1 :: Int}+ | B {b0, b1 :: Int}+and we see a record update+ x { a0 = 3, a1 = 2, b0 = 4, b1 = 5 }+Then we'd like to find the smallest subset of fields that no+constructor has all of. Here, say, {a0,b0}, or {a0,b1}, etc.+We don't really want to report that no constructor has all of+{a0,a1,b0,b1}, because when there are hundreds of fields it's+hard to see what was really wrong.++We may need more than two fields, though; eg+ data T = A { x,y :: Int, v::Int }+ | B { y,z :: Int, v::Int }+ | C { z,x :: Int, v::Int }+with update+ r { x=e1, y=e2, z=e3 }, we++Finding the smallest subset is hard, so the code here makes+a decent stab, no more. See #7989.+-}++mixedSelectors :: [Id] -> [Id] -> SDoc+mixedSelectors data_sels@(dc_rep_id:_) pat_syn_sels@(ps_rep_id:_)+ = ptext+ (sLit "Cannot use a mixture of pattern synonym and record selectors") $$+ text "Record selectors defined by"+ <+> quotes (ppr (tyConName rep_dc))+ <> text ":"+ <+> pprWithCommas ppr data_sels $$+ text "Pattern synonym selectors defined by"+ <+> quotes (ppr (patSynName rep_ps))+ <> text ":"+ <+> pprWithCommas ppr pat_syn_sels+ where+ RecSelPatSyn rep_ps = recordSelectorTyCon ps_rep_id+ RecSelData rep_dc = recordSelectorTyCon dc_rep_id+mixedSelectors _ _ = panic "GHC.Tc.Gen.Expr: mixedSelectors emptylists"+++missingStrictFields :: ConLike -> [FieldLabelString] -> SDoc+missingStrictFields con fields+ = header <> rest+ where+ rest | null fields = Outputable.empty -- Happens for non-record constructors+ -- with strict fields+ | otherwise = colon <+> pprWithCommas ppr fields++ header = text "Constructor" <+> quotes (ppr con) <+>+ text "does not have the required strict field(s)"++missingFields :: ConLike -> [FieldLabelString] -> SDoc+missingFields con fields+ = header <> rest+ where+ rest | null fields = Outputable.empty+ | otherwise = colon <+> pprWithCommas ppr fields+ header = text "Fields of" <+> quotes (ppr con) <+>+ text "not initialised"++-- callCtxt fun args = text "In the call" <+> parens (ppr (foldl' mkHsApp fun args))++noPossibleParents :: [LHsRecUpdField GhcRn] -> SDoc+noPossibleParents rbinds+ = hang (text "No type has all these fields:")+ 2 (pprQuotedList fields)+ where+ fields = map (hsRecFieldLbl . unLoc) rbinds++badOverloadedUpdate :: SDoc+badOverloadedUpdate = text "Record update is ambiguous, and requires a type signature" {- ************************************************************************
compiler/GHC/Tc/Gen/Expr.hs-boot view
@@ -1,13 +1,13 @@ module GHC.Tc.Gen.Expr where-import GHC.Types.Name-import GHC.Hs ( HsExpr, LHsExpr, SyntaxExprRn, SyntaxExprTc )+import GHC.Hs ( HsExpr, LHsExpr, SyntaxExprRn+ , SyntaxExprTc ) import GHC.Tc.Utils.TcType ( TcRhoType, TcSigmaType, SyntaxOpType, ExpType, ExpRhoType ) import GHC.Tc.Types ( TcM ) import GHC.Tc.Types.Origin ( CtOrigin ) import GHC.Core.Type ( Mult ) import GHC.Hs.Extension ( GhcRn, GhcTc ) -tcCheckPolyExpr ::+tcCheckPolyExpr, tcCheckPolyExprNC :: LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTc)@@ -23,8 +23,6 @@ tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) -tcInferSigma :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcSigmaType)- tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType) @@ -42,5 +40,3 @@ -> ([TcSigmaType] -> [Mult] -> TcM a) -> TcM (a, SyntaxExprTc) --tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTc)
compiler/GHC/Tc/Gen/Foreign.hs view
@@ -243,7 +243,7 @@ -- things are LocalIds. However, it does not need zonking, -- (so GHC.Tc.Utils.Zonk.zonkForeignExports ignores it). - ; imp_decl' <- tcCheckFIType (map scaledThing arg_tys) res_ty imp_decl+ ; imp_decl' <- tcCheckFIType arg_tys res_ty imp_decl -- Can't use sig_ty here because sig_ty :: Type and -- we need HsType Id hence the undefined ; let fi_decl = ForeignImport { fd_name = L nloc id@@ -255,14 +255,14 @@ -- ------------ Checking types for foreign import ---------------------- -tcCheckFIType :: [Type] -> Type -> ForeignImport -> TcM ForeignImport+tcCheckFIType :: [Scaled Type] -> Type -> ForeignImport -> TcM ForeignImport tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh l@(CLabel _) src) -- Foreign import label = do checkCg checkCOrAsmOrLlvmOrInterp -- NB check res_ty not sig_ty! -- In case sig_ty is (forall a. ForeignPtr a)- check (isFFILabelTy (mkVisFunTysMany arg_tys res_ty)) (illegalForeignTyErr Outputable.empty)+ check (isFFILabelTy (mkVisFunTys arg_tys res_ty)) (illegalForeignTyErr Outputable.empty) cconv' <- checkCConv cconv return (CImport (L lc cconv') safety mh l src) @@ -274,7 +274,9 @@ checkCg checkCOrAsmOrLlvmOrInterp cconv' <- checkCConv cconv case arg_tys of- [arg1_ty] -> do checkForeignArgs isFFIExternalTy (map scaledThing arg1_tys)+ [Scaled arg1_mult arg1_ty] -> do+ checkNoLinearFFI arg1_mult+ checkForeignArgs isFFIExternalTy arg1_tys checkForeignRes nonIOok checkSafe isFFIExportResultTy res1_ty checkForeignRes mustBeIO checkSafe (isFFIDynTy arg1_ty) res_ty where@@ -290,9 +292,10 @@ case arg_tys of -- The first arg must be Ptr or FunPtr [] -> addErrTc (illegalForeignTyErr Outputable.empty (text "At least one argument expected"))- (arg1_ty:arg_tys) -> do+ (Scaled arg1_mult arg1_ty:arg_tys) -> do dflags <- getDynFlags- let curried_res_ty = mkVisFunTysMany arg_tys res_ty+ let curried_res_ty = mkVisFunTys arg_tys res_ty+ checkNoLinearFFI arg1_mult check (isFFIDynTy curried_res_ty arg1_ty) (illegalForeignTyErr argument) checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys@@ -317,7 +320,7 @@ dflags <- getDynFlags checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty- checkMissingAmpersand dflags arg_tys res_ty+ checkMissingAmpersand dflags (map scaledThing arg_tys) res_ty case target of StaticTarget _ _ _ False | not (null arg_tys) ->@@ -405,7 +408,7 @@ checkCg checkCOrAsmOrLlvm checkTc (isCLabelString str) (badCName str) cconv' <- checkCConv cconv- checkForeignArgs isFFIExternalTy (map scaledThing arg_tys)+ checkForeignArgs isFFIExternalTy arg_tys checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty return (CExport (L l (CExportStatic esrc str cconv')) src) where@@ -422,10 +425,16 @@ -} ------------ Checking argument types for foreign import -----------------------checkForeignArgs :: (Type -> Validity) -> [Type] -> TcM ()+checkForeignArgs :: (Type -> Validity) -> [Scaled Type] -> TcM () checkForeignArgs pred tys = mapM_ go tys where- go ty = check (pred ty) (illegalForeignTyErr argument)+ go (Scaled mult ty) = checkNoLinearFFI mult >>+ check (pred ty) (illegalForeignTyErr argument)++checkNoLinearFFI :: Mult -> TcM () -- No linear types in FFI (#18472)+checkNoLinearFFI Many = return ()+checkNoLinearFFI _ = addErrTc $ illegalForeignTyErr argument+ (text "Linear types are not supported in FFI declarations, see #18472") ------------ Checking result types for foreign calls ---------------------- -- | Check that the type has the form
+ compiler/GHC/Tc/Gen/Head.hs view
@@ -0,0 +1,1143 @@+{-+%+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++{-# LANGUAGE CPP, TupleSections, ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies, DataKinds, GADTs, TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module GHC.Tc.Gen.Head+ ( HsExprArg(..), EValArg(..), TcPass(..), Rebuilder+ , splitHsApps+ , addArgWrap, eValArgExpr, isHsValArg, setSrcSpanFromArgs+ , countLeadingValArgs, isVisibleArg, pprHsExprArgTc, rebuildPrefixApps++ , tcInferAppHead, tcInferAppHead_maybe+ , tcInferId, tcCheckId+ , obviousSig, addAmbiguousNameErr+ , tyConOf, tyConOfET, lookupParents, fieldNotInType+ , notSelector, nonBidirectionalErr++ , addExprCtxt, addLExprCtxt, addFunResCtxt ) where++import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckMonoExprNC, tcCheckPolyExprNC )++import GHC.Tc.Gen.HsType+import GHC.Tc.Gen.Pat+import GHC.Tc.Gen.Bind( chooseInferredQuantifiers )+import GHC.Tc.Gen.Sig( tcUserTypeSig, tcInstSig )+import GHC.Tc.TyCl.PatSyn( patSynBuilderOcc )+import GHC.Tc.Utils.Monad+import GHC.Tc.Utils.Unify+import GHC.Types.Basic+import GHC.Tc.Utils.Instantiate+import GHC.Tc.Instance.Family ( tcGetFamInstEnvs, tcLookupDataFamInst )+import GHC.Core.FamInstEnv ( FamInstEnvs )+import GHC.Core.UsageEnv ( unitUE )+import GHC.Rename.Env ( addUsedGRE )+import GHC.Rename.Utils ( addNameClashErrRn, unknownSubordinateErr )+import GHC.Tc.Solver ( InferMode(..), simplifyInfer )+import GHC.Tc.Utils.Env+import GHC.Tc.Utils.TcMType+import GHC.Tc.Types.Origin+import GHC.Tc.Utils.TcType as TcType+import GHC.Hs+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Core.ConLike+import GHC.Core.DataCon+import GHC.Types.Name+import GHC.Types.Name.Reader+import GHC.Core.TyCon+import GHC.Core.TyCo.Rep+import GHC.Core.Type+import GHC.Tc.Types.Evidence+import GHC.Builtin.Types( multiplicityTy )+import GHC.Builtin.Names+import GHC.Builtin.Names.TH( liftStringName, liftName )+import GHC.Driver.Session+import GHC.Types.SrcLoc+import GHC.Utils.Misc+import GHC.Data.Maybe+import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic+import Control.Monad++import Data.Function++#include "GhclibHsVersions.h"++import GHC.Prelude+++{- *********************************************************************+* *+ HsExprArg: auxiliary data type+* *+********************************************************************* -}++{- Note [HsExprArg]+~~~~~~~~~~~~~~~~~~~+The data type HsExprArg :: TcPass -> Type+is a very local type, used only within this module and GHC.Tc.Gen.App++* It's really a zipper for an application chain+ See Note [Application chains and heads] in GHC.Tc.Gen.App for+ what an "application chain" is.++* It's a GHC-specific type, so using TTG only where necessary++* It is indexed by TcPass, meaning+ - HsExprArg TcpRn:+ The result of splitHsApps, which decomposes a HsExpr GhcRn++ - HsExprArg TcpInst:+ The result of tcInstFun, which instantiates the function type+ Adds EWrap nodes, the argument type in EValArg,+ and the kind-checked type in ETypeArg++ - HsExprArg TcpTc:+ The result of tcArg, which typechecks the value args+ In EValArg we now have a (LHsExpr GhcTc)++* rebuildPrefixApps is dual to splitHsApps, and zips an application+ back into a HsExpr++Note [EValArg]+~~~~~~~~~~~~~~+The data type EValArg is the payload of the EValArg constructor of+HsExprArg; i.e. a value argument of the application. EValArg has two+forms:++* ValArg: payload is just the expression itself. Simple.++* ValArgQL: captures the results of applying quickLookArg to the+ argument in a ValArg. When we later want to typecheck that argument+ we can just carry on from where quick-look left off. The fields of+ ValArgQL exactly capture what is needed to complete the job.++Invariants:++1. With QL switched off, all arguments are ValArg; no ValArgQL++2. With QL switched on, tcInstFun converts some ValArgs to ValArgQL,+ under the conditions when quick-look should happen (eg the argument+ type is guarded) -- see quickLookArg++Note [splitHsApps and Rebuilder]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The key function+ splitHsApps :: HsExpr GhcRn -> (HsExpr GhcRn, [HsExprArg 'TcpRn], Rebuilder)+takes apart either an HsApp, or an infix OpApp, returning++* The "head" of the application, an expression that is often a variable++* A list of HsExprArg, the arguments++* A Rebuilder function which reconstructs the original form, given the+ head and arguments. This allows us to reconstruct infix+ applications (OpApp) as well as prefix applications (HsApp),+ thereby retaining the structure of the original tree.+-}++data TcPass = TcpRn -- Arguments decomposed+ | TcpInst -- Function instantiated+ | TcpTc -- Typechecked++data HsExprArg (p :: TcPass)+ = -- See Note [HsExprArg]+ EValArg { eva_loc :: SrcSpan -- Of the function+ , eva_arg :: EValArg p+ , eva_arg_ty :: !(XEVAType p) }++ | ETypeArg { eva_loc :: SrcSpan -- Of the function+ , eva_hs_ty :: LHsWcType GhcRn -- The type arg+ , eva_ty :: !(XETAType p) } -- Kind-checked type arg++ | EPrag SrcSpan+ (HsPragE (GhcPass (XPass p)))++ | EPar SrcSpan -- Of the nested expr++ | EWrap !(XEWrap p) -- Wrapper, after instantiation++data EValArg (p :: TcPass) where -- See Note [EValArg]+ ValArg :: LHsExpr (GhcPass (XPass p))+ -> EValArg p+ ValArgQL :: { va_expr :: LHsExpr GhcRn -- Original expression+ -- For location and error msgs+ , va_fun :: HsExpr GhcTc -- Function, typechecked+ , va_args :: [HsExprArg 'TcpInst] -- Args, instantiated+ , va_ty :: TcRhoType -- Result type+ , va_rebuild :: Rebuilder } -- How to reassemble+ -> EValArg 'TcpInst -- Only exists in TcpInst phase++type Rebuilder = HsExpr GhcTc -> [HsExprArg 'TcpTc]-> HsExpr GhcTc+-- See Note [splitHsApps and Rebuilder]++type family XPass p where+ XPass 'TcpRn = 'Renamed+ XPass 'TcpInst = 'Renamed+ XPass 'TcpTc = 'Typechecked++type family XETAType p where -- Type arguments+ XETAType 'TcpRn = NoExtField+ XETAType _ = Type++type family XEVAType p where -- Value arguments+ XEVAType 'TcpRn = NoExtField+ XEVAType _ = Scaled Type++type family XEWrap p where+ XEWrap 'TcpRn = NoExtCon+ XEWrap _ = HsWrapper++mkEValArg :: SrcSpan -> LHsExpr GhcRn -> HsExprArg 'TcpRn+mkEValArg l e = EValArg { eva_loc = l, eva_arg = ValArg e+ , eva_arg_ty = noExtField }++mkETypeArg :: SrcSpan -> LHsWcType GhcRn -> HsExprArg 'TcpRn+mkETypeArg l hs_ty = ETypeArg { eva_loc = l, eva_hs_ty = hs_ty+ , eva_ty = noExtField }++eValArgExpr :: EValArg 'TcpInst -> LHsExpr GhcRn+eValArgExpr (ValArg e) = e+eValArgExpr (ValArgQL { va_expr = e }) = e++addArgWrap :: HsWrapper -> [HsExprArg 'TcpInst] -> [HsExprArg 'TcpInst]+addArgWrap wrap args+ | isIdHsWrapper wrap = args+ | otherwise = EWrap wrap : args++splitHsApps :: HsExpr GhcRn -> (HsExpr GhcRn, [HsExprArg 'TcpRn], Rebuilder)+-- See Note [splitHsApps and Rebuilder]+splitHsApps e+ = go e []+ where+ go (HsPar _ (L l fun)) args = go fun (EPar l : args)+ go (HsPragE _ p (L l fun)) args = go fun (EPrag l p : args)+ go (HsAppType _ (L l fun) hs_ty) args = go fun (mkETypeArg l hs_ty : args)+ go (HsApp _ (L l fun) arg) args = go fun (mkEValArg l arg : args)++ go (OpApp fix arg1 (L l op) arg2) args+ = (op, mkEValArg l arg1 : mkEValArg l arg2 : args, rebuild_infix fix)++ go e args = (e, args, rebuildPrefixApps)++ rebuild_infix :: Fixity -> Rebuilder+ rebuild_infix fix fun args+ = go fun args+ where+ go fun (EValArg { eva_arg = ValArg arg1, eva_loc = l } :+ EValArg { eva_arg = ValArg arg2 } : args)+ = rebuildPrefixApps (OpApp fix arg1 (L l fun) arg2) args+ go fun (EWrap wrap : args) = go (mkHsWrap wrap fun) args+ go fun args = rebuildPrefixApps fun args+ -- This last case fails to rebuild a OpApp, which is sad.+ -- It can happen if we have (e1 `op` e2),+ -- and op :: Int -> forall a. a -> Int, and e2 :: Bool+ -- Then we'll get [ e1, @Bool, e2 ]+ -- Could be fixed with WpFun, but extra complexity.++rebuildPrefixApps :: Rebuilder+rebuildPrefixApps fun args+ = go fun args+ where+ go fun [] = fun+ go fun (EWrap wrap : args) = go (mkHsWrap wrap fun) args+ go fun (EValArg { eva_arg = ValArg arg+ , eva_loc = l } : args) = go (HsApp noExtField (L l fun) arg) args+ go fun (ETypeArg { eva_hs_ty = hs_ty+ , eva_ty = ty+ , eva_loc = l } : args) = go (HsAppType ty (L l fun) hs_ty) args+ go fun (EPar l : args) = go (HsPar noExtField (L l fun)) args+ go fun (EPrag l p : args) = go (HsPragE noExtField p (L l fun)) args++isHsValArg :: HsExprArg id -> Bool+isHsValArg (EValArg {}) = True+isHsValArg _ = False++countLeadingValArgs :: [HsExprArg id] -> Int+countLeadingValArgs (EValArg {} : args) = 1 + countLeadingValArgs args+countLeadingValArgs (EPar {} : args) = countLeadingValArgs args+countLeadingValArgs (EPrag {} : args) = countLeadingValArgs args+countLeadingValArgs _ = 0++isValArg :: HsExprArg id -> Bool+isValArg (EValArg {}) = True+isValArg _ = False++isVisibleArg :: HsExprArg id -> Bool+isVisibleArg (EValArg {}) = True+isVisibleArg (ETypeArg {}) = True+isVisibleArg _ = False++setSrcSpanFromArgs :: [HsExprArg 'TcpRn] -> TcM a -> TcM a+setSrcSpanFromArgs [] thing_inside+ = thing_inside+setSrcSpanFromArgs (arg:_) thing_inside+ = setSrcSpan (argFunLoc arg) thing_inside++argFunLoc :: HsExprArg 'TcpRn -> SrcSpan+argFunLoc (EValArg { eva_loc = l }) = l+argFunLoc (ETypeArg { eva_loc = l}) = l+argFunLoc (EPrag l _) = l+argFunLoc (EPar l) = l++instance OutputableBndrId (XPass p) => Outputable (HsExprArg p) where+ ppr (EValArg { eva_arg = arg }) = text "EValArg" <+> ppr arg+ ppr (EPrag _ p) = text "EPrag" <+> ppr p+ ppr (ETypeArg { eva_hs_ty = hs_ty }) = char '@' <> ppr hs_ty+ ppr (EPar _) = text "EPar"+ ppr (EWrap _) = text "EWrap"+ -- ToDo: to print the wrapper properly we'll need to work harder+ -- "Work harder" = replicate the ghcPass approach, but I didn't+ -- think it was worth the effort to do so.++instance OutputableBndrId (XPass p) => Outputable (EValArg p) where+ ppr (ValArg e) = ppr e+ ppr (ValArgQL { va_fun = fun, va_args = args, va_ty = ty})+ = hang (text "ValArgQL" <+> ppr fun)+ 2 (vcat [ ppr args, text "va_ty:" <+> ppr ty ])++pprHsExprArgTc :: HsExprArg 'TcpInst -> SDoc+pprHsExprArgTc (EValArg { eva_arg = tm, eva_arg_ty = ty })+ = text "EValArg" <+> hang (ppr tm) 2 (dcolon <+> ppr ty)+pprHsExprArgTc arg = ppr arg+++{- *********************************************************************+* *+ tcInferAppHead+* *+********************************************************************* -}++tcInferAppHead :: HsExpr GhcRn+ -> [HsExprArg 'TcpRn] -> Maybe TcRhoType+ -- These two args are solely for tcInferRecSelId+ -> TcM (HsExpr GhcTc, TcSigmaType)+-- Infer type of the head of an application+-- i.e. the 'f' in (f e1 ... en)+-- See Note [Application chains and heads] in GHC.Tc.Gen.App+-- We get back a /SigmaType/ because we have special cases for+-- * A bare identifier (just look it up)+-- This case also covers a record selectro HsRecFld+-- * An expression with a type signature (e :: ty)+-- See Note [Application chains and heads] in GHC.Tc.Gen.App+--+-- Why do we need the arguments to infer the type of the head of+-- the application? For two reasons:+-- * (Legitimate) The first arg has the source location of the head+-- * (Disgusting) Needed for record disambiguation; see tcInferRecSelId+--+-- Note that [] and (,,) are both HsVar:+-- see Note [Empty lists] and [ExplicitTuple] in GHC.Hs.Expr+--+-- NB: 'e' cannot be HsApp, HsTyApp, HsPrag, HsPar, because those+-- cases are dealt with by splitHsApps.+--+-- See Note [tcApp: typechecking applications] in GHC.Tc.Gen.App+tcInferAppHead fun args mb_res_ty+ = setSrcSpanFromArgs args $+ do { mb_tc_fun <- tcInferAppHead_maybe fun args mb_res_ty+ ; case mb_tc_fun of+ Just (fun', fun_sigma) -> return (fun', fun_sigma)+ Nothing -> add_head_ctxt fun args $+ tcInfer (tcExpr fun) }++tcInferAppHead_maybe :: HsExpr GhcRn+ -> [HsExprArg 'TcpRn] -> Maybe TcRhoType+ -- These two args are solely for tcInferRecSelId+ -> TcM (Maybe (HsExpr GhcTc, TcSigmaType))+-- See Note [Application chains and heads] in GHC.Tc.Gen.App+-- Returns Nothing for a complicated head+tcInferAppHead_maybe fun args mb_res_ty+ = case fun of+ HsVar _ (L _ nm) -> Just <$> tcInferId nm+ HsRecFld _ f -> Just <$> tcInferRecSelId f args mb_res_ty+ ExprWithTySig _ e hs_ty -> add_head_ctxt fun args $+ Just <$> tcExprWithSig e hs_ty+ _ -> return Nothing++add_head_ctxt :: HsExpr GhcRn -> [HsExprArg 'TcpRn] -> TcM a -> TcM a+-- Don't push an expression context if the arguments are empty,+-- because it has already been pushed by tcExpr+add_head_ctxt fun args thing_inside+ | null args = thing_inside+ | otherwise = addExprCtxt fun thing_inside+++{- *********************************************************************+* *+ Record selectors+* *+********************************************************************* -}++{- Note [Disambiguating record fields]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When the -XDuplicateRecordFields extension is used, and the renamer+encounters a record selector or update that it cannot immediately+disambiguate (because it involves fields that belong to multiple+datatypes), it will defer resolution of the ambiguity to the+typechecker. In this case, the `Ambiguous` constructor of+`AmbiguousFieldOcc` is used.++Consider the following definitions:++ data S = MkS { foo :: Int }+ data T = MkT { foo :: Int, bar :: Int }+ data U = MkU { bar :: Int, baz :: Int }++When the renamer sees `foo` as a selector or an update, it will not+know which parent datatype is in use.++For selectors, there are two possible ways to disambiguate:++1. Check if the pushed-in type is a function whose domain is a+ datatype, for example:++ f s = (foo :: S -> Int) s++ g :: T -> Int+ g = foo++ This is checked by `tcCheckRecSelId` when checking `HsRecFld foo`.++2. Check if the selector is applied to an argument that has a type+ signature, for example:++ h = foo (s :: S)++ This is checked by `tcInferRecSelId`.+++Updates are slightly more complex. The `disambiguateRecordBinds`+function tries to determine the parent datatype in three ways:++1. Check for types that have all the fields being updated. For example:++ f x = x { foo = 3, bar = 2 }++ Here `f` must be updating `T` because neither `S` nor `U` have+ both fields. This may also discover that no possible type exists.+ For example the following will be rejected:++ f' x = x { foo = 3, baz = 3 }++2. Use the type being pushed in, if it is already a TyConApp. The+ following are valid updates to `T`:++ g :: T -> T+ g x = x { foo = 3 }++ g' x = x { foo = 3 } :: T++3. Use the type signature of the record expression, if it exists and+ is a TyConApp. Thus this is valid update to `T`:++ h x = (x :: T) { foo = 3 }+++Note that we do not look up the types of variables being updated, and+no constraint-solving is performed, so for example the following will+be rejected as ambiguous:++ let bad (s :: S) = foo s++ let r :: T+ r = blah+ in r { foo = 3 }++ \r. (r { foo = 3 }, r :: T )++We could add further tests, of a more heuristic nature. For example,+rather than looking for an explicit signature, we could try to infer+the type of the argument to a selector or the record expression being+updated, in case we are lucky enough to get a TyConApp straight+away. However, it might be hard for programmers to predict whether a+particular update is sufficiently obvious for the signature to be+omitted. Moreover, this might change the behaviour of typechecker in+non-obvious ways.++See also Note [HsRecField and HsRecUpdField] in GHC.Hs.Pat.+-}++tcInferRecSelId :: AmbiguousFieldOcc GhcRn+ -> [HsExprArg 'TcpRn] -> Maybe TcRhoType+ -> TcM (HsExpr GhcTc, TcSigmaType)+tcInferRecSelId (Unambiguous sel_name lbl) _args _mb_res_ty+ = do { sel_id <- tc_rec_sel_id lbl sel_name+ ; let expr = HsRecFld noExtField (Unambiguous sel_id lbl)+ ; return (expr, idType sel_id) }++tcInferRecSelId (Ambiguous _ lbl) args mb_res_ty+ = do { sel_name <- tcInferAmbiguousRecSelId lbl args mb_res_ty+ ; sel_id <- tc_rec_sel_id lbl sel_name+ ; let expr = HsRecFld noExtField (Ambiguous sel_id lbl)+ ; return (expr, idType sel_id) }++------------------------+tc_rec_sel_id :: Located RdrName -> Name -> TcM TcId+-- Like tc_infer_id, but returns an Id not a HsExpr,+-- so we can wrap it back up into a HsRecFld+tc_rec_sel_id lbl sel_name+ = do { thing <- tcLookup sel_name+ ; case thing of+ ATcId { tct_id = id }+ -> do { check_local_id occ id+ ; return id }++ AGlobal (AnId id)+ -> do { check_global_id occ id+ ; return id }+ -- A global cannot possibly be ill-staged+ -- nor does it need the 'lifting' treatment+ -- hence no checkTh stuff here++ _ -> failWithTc $+ ppr thing <+> text "used where a value identifier was expected" }+ where+ occ = rdrNameOcc (unLoc lbl)++------------------------+tcInferAmbiguousRecSelId :: Located RdrName+ -> [HsExprArg 'TcpRn] -> Maybe TcRhoType+ -> TcM Name+-- Disgusting special case for ambiguous record selectors+-- Given a RdrName that refers to multiple record fields, and the type+-- of its argument, try to determine the name of the selector that is+-- meant.+-- See Note [Disambiguating record fields]+tcInferAmbiguousRecSelId lbl args mb_res_ty+ | arg1 : _ <- dropWhile (not . isVisibleArg) args -- A value arg is first+ , EValArg { eva_arg = ValArg (L _ arg) } <- arg1+ , Just sig_ty <- obviousSig arg -- A type sig on the arg disambiguates+ = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty+ ; finish_ambiguous_selector lbl sig_tc_ty }++ | Just res_ty <- mb_res_ty+ , Just (arg_ty,_) <- tcSplitFunTy_maybe res_ty+ = finish_ambiguous_selector lbl (scaledThing arg_ty)++ | otherwise+ = ambiguousSelector lbl++finish_ambiguous_selector :: Located RdrName -> Type -> TcM Name+finish_ambiguous_selector lr@(L _ rdr) parent_type+ = do { fam_inst_envs <- tcGetFamInstEnvs+ ; case tyConOf fam_inst_envs parent_type of {+ Nothing -> ambiguousSelector lr ;+ Just p ->++ do { xs <- lookupParents rdr+ ; let parent = RecSelData p+ ; case lookup parent xs of {+ Nothing -> failWithTc (fieldNotInType parent rdr) ;+ Just gre ->++ do { addUsedGRE True gre+ ; return (gre_name gre) } } } } }++-- This field name really is ambiguous, so add a suitable "ambiguous+-- occurrence" error, then give up.+ambiguousSelector :: Located RdrName -> TcM a+ambiguousSelector (L _ rdr)+ = do { addAmbiguousNameErr rdr+ ; failM }++-- | This name really is ambiguous, so add a suitable "ambiguous+-- occurrence" error, then continue+addAmbiguousNameErr :: RdrName -> TcM ()+addAmbiguousNameErr rdr+ = do { env <- getGlobalRdrEnv+ ; let gres = lookupGRE_RdrName rdr env+ ; setErrCtxt [] $ addNameClashErrRn rdr gres}++-- A type signature on the argument of an ambiguous record selector or+-- the record expression in an update must be "obvious", i.e. the+-- outermost constructor ignoring parentheses.+obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)+obviousSig (ExprWithTySig _ _ ty) = Just ty+obviousSig (HsPar _ p) = obviousSig (unLoc p)+obviousSig (HsPragE _ _ p) = obviousSig (unLoc p)+obviousSig _ = Nothing++-- Extract the outermost TyCon of a type, if there is one; for+-- data families this is the representation tycon (because that's+-- where the fields live).+tyConOf :: FamInstEnvs -> TcSigmaType -> Maybe TyCon+tyConOf fam_inst_envs ty0+ = case tcSplitTyConApp_maybe ty of+ Just (tc, tys) -> Just (fstOf3 (tcLookupDataFamInst fam_inst_envs tc tys))+ Nothing -> Nothing+ where+ (_, _, ty) = tcSplitSigmaTy ty0++-- Variant of tyConOf that works for ExpTypes+tyConOfET :: FamInstEnvs -> ExpRhoType -> Maybe TyCon+tyConOfET fam_inst_envs ty0 = tyConOf fam_inst_envs =<< checkingExpType_maybe ty0+++-- For an ambiguous record field, find all the candidate record+-- selectors (as GlobalRdrElts) and their parents.+lookupParents :: RdrName -> RnM [(RecSelParent, GlobalRdrElt)]+lookupParents rdr+ = do { env <- getGlobalRdrEnv+ ; let gres = lookupGRE_RdrName rdr env+ ; mapM lookupParent gres }+ where+ lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt)+ lookupParent gre = do { id <- tcLookupId (gre_name gre)+ ; if isRecordSelector id+ then return (recordSelectorTyCon id, gre)+ else failWithTc (notSelector (gre_name gre)) }+++fieldNotInType :: RecSelParent -> RdrName -> SDoc+fieldNotInType p rdr+ = unknownSubordinateErr (text "field of type" <+> quotes (ppr p)) rdr++notSelector :: Name -> SDoc+notSelector field+ = hsep [quotes (ppr field), text "is not a record selector"]++naughtyRecordSel :: OccName -> SDoc+naughtyRecordSel lbl+ = text "Cannot use record selector" <+> quotes (ppr lbl) <+>+ text "as a function due to escaped type variables" $$+ text "Probable fix: use pattern-matching syntax instead"+++{- *********************************************************************+* *+ Expressions with a type signature+ expr :: type+* *+********************************************************************* -}++tcExprWithSig :: LHsExpr GhcRn -> LHsSigWcType (NoGhcTc GhcRn)+ -> TcM (HsExpr GhcTc, TcSigmaType)+tcExprWithSig expr hs_ty+ = do { sig_info <- checkNoErrs $ -- Avoid error cascade+ tcUserTypeSig loc hs_ty Nothing+ ; (expr', poly_ty) <- tcExprSig expr sig_info+ ; return (ExprWithTySig noExtField expr' hs_ty, poly_ty) }+ where+ loc = getLoc (hsSigWcType hs_ty)++tcExprSig :: LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcType)+tcExprSig expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc })+ = setSrcSpan loc $ -- Sets the location for the implication constraint+ do { let poly_ty = idType poly_id+ ; (wrap, expr') <- tcSkolemiseScoped ExprSigCtxt poly_ty $ \rho_ty ->+ tcCheckMonoExprNC expr rho_ty+ ; return (mkLHsWrap wrap expr', poly_ty) }++tcExprSig expr sig@(PartialSig { psig_name = name, sig_loc = loc })+ = setSrcSpan loc $ -- Sets the location for the implication constraint+ do { (tclvl, wanted, (expr', sig_inst))+ <- pushLevelAndCaptureConstraints $+ do { sig_inst <- tcInstSig sig+ ; expr' <- tcExtendNameTyVarEnv (mapSnd binderVar $ sig_inst_skols sig_inst) $+ tcExtendNameTyVarEnv (sig_inst_wcs sig_inst) $+ tcCheckPolyExprNC expr (sig_inst_tau sig_inst)+ ; return (expr', sig_inst) }+ -- See Note [Partial expression signatures]+ ; let tau = sig_inst_tau sig_inst+ infer_mode | null (sig_inst_theta sig_inst)+ , isNothing (sig_inst_wcx sig_inst)+ = ApplyMR+ | otherwise+ = NoRestrictions+ ; (qtvs, givens, ev_binds, residual, _)+ <- simplifyInfer tclvl infer_mode [sig_inst] [(name, tau)] wanted+ ; emitConstraints residual++ ; tau <- zonkTcType tau+ ; let inferred_theta = map evVarPred givens+ tau_tvs = tyCoVarsOfType tau+ ; (binders, my_theta) <- chooseInferredQuantifiers inferred_theta+ tau_tvs qtvs (Just sig_inst)+ ; let inferred_sigma = mkInfSigmaTy qtvs inferred_theta tau+ my_sigma = mkInvisForAllTys binders (mkPhiTy my_theta tau)+ ; wrap <- if inferred_sigma `eqType` my_sigma -- NB: eqType ignores vis.+ then return idHsWrapper -- Fast path; also avoids complaint when we infer+ -- an ambiguous type and have AllowAmbiguousType+ -- e..g infer x :: forall a. F a -> Int+ else tcSubTypeSigma ExprSigCtxt inferred_sigma my_sigma++ ; traceTc "tcExpSig" (ppr qtvs $$ ppr givens $$ ppr inferred_sigma $$ ppr my_sigma)+ ; let poly_wrap = wrap+ <.> mkWpTyLams qtvs+ <.> mkWpLams givens+ <.> mkWpLet ev_binds+ ; return (mkLHsWrap poly_wrap expr', my_sigma) }+++{- Note [Partial expression signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Partial type signatures on expressions are easy to get wrong. But+here is a guiding principile+ e :: ty+should behave like+ let x :: ty+ x = e+ in x++So for partial signatures we apply the MR if no context is given. So+ e :: IO _ apply the MR+ e :: _ => IO _ do not apply the MR+just like in GHC.Tc.Gen.Bind.decideGeneralisationPlan++This makes a difference (#11670):+ peek :: Ptr a -> IO CLong+ peek ptr = peekElemOff undefined 0 :: _+from (peekElemOff undefined 0) we get+ type: IO w+ constraints: Storable w++We must NOT try to generalise over 'w' because the signature specifies+no constraints so we'll complain about not being able to solve+Storable w. Instead, don't generalise; then _ gets instantiated to+CLong, as it should.+-}+++{- *********************************************************************+* *+ tcInferId, tcCheckId+* *+********************************************************************* -}++tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTc)+tcCheckId name res_ty+ = do { (expr, actual_res_ty) <- tcInferId name+ ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty])+ ; addFunResCtxt expr [] actual_res_ty res_ty $+ tcWrapResultO (OccurrenceOf name) (HsVar noExtField (noLoc name)) expr+ actual_res_ty res_ty }++------------------------+tcInferId :: Name -> TcM (HsExpr GhcTc, TcSigmaType)+-- Look up an occurrence of an Id+-- Do not instantiate its type+tcInferId id_name+ | id_name `hasKey` assertIdKey+ = do { dflags <- getDynFlags+ ; if gopt Opt_IgnoreAsserts dflags+ then tc_infer_id id_name+ else tc_infer_assert id_name }++ | otherwise+ = do { (expr, ty) <- tc_infer_id id_name+ ; traceTc "tcInferId" (ppr id_name <+> dcolon <+> ppr ty)+ ; return (expr, ty) }++tc_infer_assert :: Name -> TcM (HsExpr GhcTc, TcSigmaType)+-- Deal with an occurrence of 'assert'+-- See Note [Adding the implicit parameter to 'assert']+tc_infer_assert assert_name+ = do { assert_error_id <- tcLookupId assertErrorName+ ; (wrap, id_rho) <- topInstantiate (OccurrenceOf assert_name)+ (idType assert_error_id)+ ; return (mkHsWrap wrap (HsVar noExtField (noLoc assert_error_id)), id_rho)+ }++tc_infer_id :: Name -> TcM (HsExpr GhcTc, TcSigmaType)+tc_infer_id id_name+ = do { thing <- tcLookup id_name+ ; case thing of+ ATcId { tct_id = id }+ -> do { check_local_id occ id+ ; return_id id }++ AGlobal (AnId id)+ -> do { check_global_id occ id+ ; return_id id }++ AGlobal (AConLike cl) -> case cl of+ RealDataCon con -> return_data_con con+ PatSynCon ps+ | Just (expr, ty) <- patSynBuilderOcc ps+ -> return (expr, ty)+ | otherwise+ -> nonBidirectionalErr id_name++ _ -> failWithTc $+ ppr thing <+> text "used where a value identifier was expected" }+ where+ occ = nameOccName id_name++ return_id id = return (HsVar noExtField (noLoc id), idType id)++ return_data_con con+ = do { let tvs = dataConUserTyVarBinders con+ theta = dataConOtherTheta con+ args = dataConOrigArgTys con+ res = dataConOrigResTy con++ -- See Note [Linear fields generalization]+ ; mul_vars <- newFlexiTyVarTys (length args) multiplicityTy+ ; let scaleArgs args' = zipWithEqual "return_data_con" combine mul_vars args'+ combine var (Scaled One ty) = Scaled var ty+ combine _ scaled_ty = scaled_ty+ -- The combine function implements the fact that, as+ -- described in Note [Linear fields generalization], if a+ -- field is not linear (last line) it isn't made polymorphic.++ etaWrapper arg_tys = foldr (\scaled_ty wr -> WpFun WpHole wr scaled_ty empty) WpHole arg_tys++ -- See Note [Instantiating stupid theta]+ ; let shouldInstantiate = (not (null (dataConStupidTheta con)) ||+ isKindLevPoly (tyConResKind (dataConTyCon con)))+ ; case shouldInstantiate of+ True -> do { (subst, tvs') <- newMetaTyVars (binderVars tvs)+ ; let tys' = mkTyVarTys tvs'+ theta' = substTheta subst theta+ args' = substScaledTys subst args+ res' = substTy subst res+ ; wrap <- instCall (OccurrenceOf id_name) tys' theta'+ ; let scaled_arg_tys = scaleArgs args'+ eta_wrap = etaWrapper scaled_arg_tys+ ; addDataConStupidTheta con tys'+ ; return ( mkHsWrap (eta_wrap <.> wrap)+ (HsConLikeOut noExtField (RealDataCon con))+ , mkVisFunTys scaled_arg_tys res')+ }+ False -> let scaled_arg_tys = scaleArgs args+ wrap1 = mkWpTyApps (mkTyVarTys $ binderVars tvs)+ eta_wrap = etaWrapper (map unrestricted theta ++ scaled_arg_tys)+ wrap2 = mkWpTyLams $ binderVars tvs+ in return ( mkHsWrap (wrap2 <.> eta_wrap <.> wrap1)+ (HsConLikeOut noExtField (RealDataCon con))+ , mkInvisForAllTys tvs $ mkInvisFunTysMany theta $ mkVisFunTys scaled_arg_tys res)+ }++check_local_id :: OccName -> Id -> TcM ()+check_local_id occ id+ = do { check_naughty occ id -- See Note [HsVar: naughty record selectors]+ ; checkThLocalId id+ ; tcEmitBindingUsage $ unitUE (idName id) One }++check_global_id :: OccName -> Id -> TcM ()+check_global_id occ id+ = check_naughty occ id -- See Note [HsVar: naughty record selectors]+ -- A global cannot possibly be ill-staged+ -- nor does it need the 'lifting' treatment+ -- Hence no checkTh stuff here++check_naughty :: OccName -> TcId -> TcM ()+check_naughty lbl id+ | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel lbl)+ | otherwise = return ()++nonBidirectionalErr :: Outputable name => name -> TcM a+nonBidirectionalErr name = failWithTc $+ text "non-bidirectional pattern synonym"+ <+> quotes (ppr name) <+> text "used in an expression"++{- Note [HsVar: naughty record selectors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+All record selectors should really be HsRecFld (ambiguous or+unambiguous), but currently not all of them are: see #18452. So we+need to check for naughty record selectors in tc_infer_id, as well as+in tc_rec_sel_id.++Remove this code when fixing #18452.++Note [Linear fields generalization]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As per Note [Polymorphisation of linear fields], linear field of data+constructors get a polymorphic type when the data constructor is used as a term.++ Just :: forall {p} a. a #p-> Maybe a++This rule is known only to the typechecker: Just keeps its linear type in Core.++In order to desugar this generalised typing rule, we simply eta-expand:++ \a (x # p :: a) -> Just @a x++has the appropriate type. We insert these eta-expansion with WpFun wrappers.++A small hitch: if the constructor is levity-polymorphic (unboxed tuples, sums,+certain newtypes with -XUnliftedNewtypes) then this strategy produces++ \r1 r2 a b (x # p :: a) (y # q :: b) -> (# a, b #)++Which has type++ forall r1 r2 a b. a #p-> b #q-> (# a, b #)++Which violates the levity-polymorphism restriction see Note [Levity polymorphism+checking] in DsMonad.++So we really must instantiate r1 and r2 rather than quantify over them. For+simplicity, we just instantiate the entire type, as described in Note+[Instantiating stupid theta]. It breaks visible type application with unboxed+tuples, sums and levity-polymorphic newtypes, but this doesn't appear to be used+anywhere.++A better plan: let's force all representation variable to be *inferred*, so that+they are not subject to visible type applications. Then we can instantiate+inferred argument eagerly.++Note [Adding the implicit parameter to 'assert']+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The typechecker transforms (assert e1 e2) to (assertError e1 e2).+This isn't really the Right Thing because there's no way to "undo"+if you want to see the original source code in the typechecker+output. We'll have fix this in due course, when we care more about+being able to reconstruct the exact original program.+++Note [Instantiating stupid theta]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Normally, when we infer the type of an Id, we don't instantiate,+because we wish to allow for visible type application later on.+But if a datacon has a stupid theta, we're a bit stuck. We need+to emit the stupid theta constraints with instantiated types. It's+difficult to defer this to the lazy instantiation, because a stupid+theta has no spot to put it in a type. So we just instantiate eagerly+in this case. Thus, users cannot use visible type application with+a data constructor sporting a stupid theta. I won't feel so bad for+the users that complain.+-}++{-+************************************************************************+* *+ Template Haskell checks+* *+************************************************************************+-}++checkThLocalId :: Id -> TcM ()+-- The renamer has already done checkWellStaged,+-- in RnSplice.checkThLocalName, so don't repeat that here.+-- Here we just add constraints for cross-stage lifting+checkThLocalId id+ = do { mb_local_use <- getStageAndBindLevel (idName id)+ ; case mb_local_use of+ Just (top_lvl, bind_lvl, use_stage)+ | thLevel use_stage > bind_lvl+ -> checkCrossStageLifting top_lvl id use_stage+ _ -> return () -- Not a locally-bound thing, or+ -- no cross-stage link+ }++--------------------------------------+checkCrossStageLifting :: TopLevelFlag -> Id -> ThStage -> TcM ()+-- If we are inside typed brackets, and (use_lvl > bind_lvl)+-- we must check whether there's a cross-stage lift to do+-- Examples \x -> [|| x ||]+-- [|| map ||]+--+-- This is similar to checkCrossStageLifting in GHC.Rename.Splice, but+-- this code is applied to *typed* brackets.++checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var q))+ | isTopLevel top_lvl+ = when (isExternalName id_name) (keepAlive id_name)+ -- See Note [Keeping things alive for Template Haskell] in GHC.Rename.Splice++ | otherwise+ = -- Nested identifiers, such as 'x' in+ -- E.g. \x -> [|| h x ||]+ -- We must behave as if the reference to x was+ -- h $(lift x)+ -- We use 'x' itself as the splice proxy, used by+ -- the desugarer to stitch it all back together.+ -- If 'x' occurs many times we may get many identical+ -- bindings of the same splice proxy, but that doesn't+ -- matter, although it's a mite untidy.+ do { let id_ty = idType id+ ; checkTc (isTauTy id_ty) (polySpliceErr id)+ -- If x is polymorphic, its occurrence sites might+ -- have different instantiations, so we can't use plain+ -- 'x' as the splice proxy name. I don't know how to+ -- solve this, and it's probably unimportant, so I'm+ -- just going to flag an error for now++ ; lift <- if isStringTy id_ty then+ do { sid <- tcLookupId GHC.Builtin.Names.TH.liftStringName+ -- See Note [Lifting strings]+ ; return (HsVar noExtField (noLoc sid)) }+ else+ setConstraintVar lie_var $+ -- Put the 'lift' constraint into the right LIE+ newMethodFromName (OccurrenceOf id_name)+ GHC.Builtin.Names.TH.liftName+ [getRuntimeRep id_ty, id_ty]++ -- Update the pending splices+ ; ps <- readMutVar ps_var+ ; let pending_splice = PendingTcSplice id_name+ (nlHsApp (mkLHsWrap (applyQuoteWrapper q) (noLoc lift))+ (nlHsVar id))+ ; writeMutVar ps_var (pending_splice : ps)++ ; return () }+ where+ id_name = idName id++checkCrossStageLifting _ _ _ = return ()++polySpliceErr :: Id -> SDoc+polySpliceErr id+ = text "Can't splice the polymorphic local variable" <+> quotes (ppr id)++{-+Note [Lifting strings]+~~~~~~~~~~~~~~~~~~~~~~+If we see $(... [| s |] ...) where s::String, we don't want to+generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc.+So this conditional short-circuits the lifting mechanism to generate+(liftString "xy") in that case. I didn't want to use overlapping instances+for the Lift class in TH.Syntax, because that can lead to overlapping-instance+errors in a polymorphic situation.++If this check fails (which isn't impossible) we get another chance; see+Note [Converting strings] in Convert.hs++Local record selectors+~~~~~~~~~~~~~~~~~~~~~~+Record selectors for TyCons in this module are ordinary local bindings,+which show up as ATcIds rather than AGlobals. So we need to check for+naughtiness in both branches. c.f. TcTyClsBindings.mkAuxBinds.+-}+++{- *********************************************************************+* *+ Error reporting for function result mis-matches+* *+********************************************************************* -}++addFunResCtxt :: HsExpr GhcTc -> [HsExprArg 'TcpTc]+ -> TcType -> ExpRhoType+ -> TcM a -> TcM a+-- When we have a mis-match in the return type of a function+-- try to give a helpful message about too many/few arguments+addFunResCtxt fun args fun_res_ty env_ty+ = addLandmarkErrCtxtM (\env -> (env, ) <$> mk_msg)+ -- NB: use a landmark error context, so that an empty context+ -- doesn't suppress some more useful context+ where+ mk_msg+ = do { mb_env_ty <- readExpType_maybe env_ty+ -- by the time the message is rendered, the ExpType+ -- will be filled in (except if we're debugging)+ ; fun_res' <- zonkTcType fun_res_ty+ ; env' <- case mb_env_ty of+ Just env_ty -> zonkTcType env_ty+ Nothing ->+ do { dumping <- doptM Opt_D_dump_tc_trace+ ; MASSERT( dumping )+ ; newFlexiTyVarTy liftedTypeKind }+ ; let -- See Note [Splitting nested sigma types in mismatched+ -- function types]+ (_, _, fun_tau) = tcSplitNestedSigmaTys fun_res'+ -- No need to call tcSplitNestedSigmaTys here, since env_ty is+ -- an ExpRhoTy, i.e., it's already instantiated.+ (_, _, env_tau) = tcSplitSigmaTy env'+ (args_fun, res_fun) = tcSplitFunTys fun_tau+ (args_env, res_env) = tcSplitFunTys env_tau+ n_fun = length args_fun+ n_env = length args_env+ info | -- Check for too few args+ -- fun_tau = a -> b, res_tau = Int+ n_fun > n_env+ , not_fun res_env+ = text "Probable cause:" <+> quotes (ppr fun)+ <+> text "is applied to too few arguments"++ | -- Check for too many args+ -- fun_tau = a -> Int, res_tau = a -> b -> c -> d+ -- The final guard suppresses the message when there+ -- aren't enough args to drop; eg. the call is (f e1)+ n_fun < n_env+ , not_fun res_fun+ , (n_fun + count isValArg args) >= n_env+ -- Never suggest that a naked variable is+ -- applied to too many args!+ = text "Possible cause:" <+> quotes (ppr fun)+ <+> text "is applied to too many arguments"++ | otherwise+ = Outputable.empty++ ; return info }+ where+ not_fun ty -- ty is definitely not an arrow type,+ -- and cannot conceivably become one+ = case tcSplitTyConApp_maybe ty of+ Just (tc, _) -> isAlgTyCon tc+ Nothing -> False++{-+Note [Splitting nested sigma types in mismatched function types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When one applies a function to too few arguments, GHC tries to determine this+fact if possible so that it may give a helpful error message. It accomplishes+this by checking if the type of the applied function has more argument types+than supplied arguments.++Previously, GHC computed the number of argument types through tcSplitSigmaTy.+This is incorrect in the face of nested foralls, however! This caused Trac+#13311, for instance:++ f :: forall a. (Monoid a) => forall b. (Monoid b) => Maybe a -> Maybe b++If one uses `f` like so:++ do { f; putChar 'a' }++Then tcSplitSigmaTy will decompose the type of `f` into:++ Tyvars: [a]+ Context: (Monoid a)+ Argument types: []+ Return type: forall b. Monoid b => Maybe a -> Maybe b++That is, it will conclude that there are *no* argument types, and since `f`+was given no arguments, it won't print a helpful error message. On the other+hand, tcSplitNestedSigmaTys correctly decomposes `f`'s type down to:++ Tyvars: [a, b]+ Context: (Monoid a, Monoid b)+ Argument types: [Maybe a]+ Return type: Maybe b++So now GHC recognizes that `f` has one more argument type than it was actually+provided.+-}+++{- *********************************************************************+* *+ Misc utility functions+* *+********************************************************************* -}++addLExprCtxt :: LHsExpr GhcRn -> TcRn a -> TcRn a+addLExprCtxt (L _ e) thing_inside = addExprCtxt e thing_inside++addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a+addExprCtxt e thing_inside+ = case e of+ HsUnboundVar {} -> thing_inside+ _ -> addErrCtxt (exprCtxt e) thing_inside+ -- The HsUnboundVar special case addresses situations like+ -- f x = _+ -- when we don't want to say "In the expression: _",+ -- because it is mentioned in the error message itself++exprCtxt :: HsExpr GhcRn -> SDoc+exprCtxt expr = hang (text "In the expression:") 2 (ppr (stripParensHsExpr expr))+
compiler/GHC/Tc/Gen/HsType.hs view
@@ -49,8 +49,6 @@ tcInferLHsTypeKind, tcInferLHsType, tcInferLHsTypeUnsaturated, tcCheckLHsType, tcHsMbContext, tcHsContext, tcLHsPredType,- failIfEmitsConstraints,- solveEqualities, -- useful re-export kindGeneralizeAll, kindGeneralizeSome, kindGeneralizeNone, @@ -87,7 +85,6 @@ import GHC.Tc.Utils.Zonk import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Ppr-import GHC.Tc.Errors ( reportAllUnsolved ) import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Instantiate ( tcInstInvisibleTyBindersN, tcInstInvisibleTyBinder ) import GHC.Core.Type@@ -187,43 +184,122 @@ Note [Recipe for checking a signature] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Checking a user-written signature requires several steps:+Kind-checking a user-written signature requires several steps: - 1. Generate constraints.- 2. Solve constraints.- 3. Promote tyvars and/or kind-generalize.- 4. Zonk.- 5. Check validity.+ 0. Bump the TcLevel+ 1. Bind any lexically-scoped type variables.+ 2. Generate constraints.+ 3. Solve constraints.+ 4. Sort any implicitly-bound variables into dependency order+ 5. Promote tyvars and/or kind-generalize.+ 6. Zonk.+ 7. Check validity. -There may be some surprises in here:+Very similar steps also apply when kind-checking a type or class+declaration. -Step 2 is necessary for two reasons: most signatures also bring-implicitly quantified variables into scope, and solving is necessary-to get these in the right order (see Note [Keeping implicitly-quantified variables in order]). Additionally, solving is necessary in-order to kind-generalize correctly: otherwise, we do not know which-metavariables are left unsolved.+The general pattern looks something like this. (But NB every+specific instance varies in one way or another!) -Step 3 is done by a call to candidateQTyVarsOfType, followed by a call to-kindGeneralize{All,Some,None}. Here, we have to deal with the fact that-metatyvars generated in the type may have a bumped TcLevel, because explicit-foralls raise the TcLevel. To avoid these variables from ever being visible in-the surrounding context, we must obey the following dictum:+ do { (tclvl, wanted, (spec_tkvs, ty))+ <- pushLevelAndSolveEqualitiesX "tc_top_lhs_type" $+ bindImplicitTKBndrs_Skol sig_vars $+ <kind-check the type> + ; spec_tkvs <- zonkAndScopedSort spec_tkvs++ ; reportUnsolvedEqualities skol_info spec_tkvs tclvl wanted++ ; let ty1 = mkSpecForAllTys spec_tkvs ty+ ; kvs <- kindGeneralizeAll ty1++ ; final_ty <- zonkTcTypeToType (mkInfForAllTys kvs ty1)++ ; checkValidType final_ty++This pattern is repeated many times in GHC.Tc.Gen.HsType,+GHC.Tc.Gen.Sig, and GHC.Tc.TyCl, with variations. In more detail:++* pushLevelAndSolveEqualitiesX (Step 0, step 3) bumps the TcLevel,+ calls the thing inside to generate constraints, solves those+ constraints as much as possible, returning the residual unsolved+ constraints in 'wanted'.++* bindImplicitTKBndrs_Skol (Step 1) binds the user-specified type+ variables E.g. when kind-checking f :: forall a. F a -> a we must+ bring 'a' into scope before kind-checking (F a -> a)++* zonkAndScopedSort (Step 4) puts those user-specified variables in+ the dependency order. (For "implicit" variables the order is no+ user-specified. E.g. forall (a::k1) (b::k2). blah k1 and k2 are+ implicitly brought into scope.++* reportUnsolvedEqualities (Step 3 continued) reports any unsolved+ equalities, carefully wrapping them in an implication that binds the+ skolems. We can't do that in pushLevelAndSolveEqualitiesX because+ that function doesn't have access to the skolems.++* kindGeneralize (Step 5). See Note [Kind generalisation]++* The final zonkTcTypeToType must happen after promoting/generalizing,+ because promoting and generalizing fill in metavariables.+++Doing Step 3 (constraint solving) eagerly (rather than building an+implication constraint and solving later) is necessary for several+reasons:++* Exactly as for Solver.simplifyInfer: when generalising, we solve all+ the constraints we can so that we don't have to quantify over them+ or, since we don't quantify over constraints in kinds, float them+ and inhibit generalisation.++* Most signatures also bring implicitly quantified variables into+ scope, and solving is necessary to get these in the right order+ (Step 4) see Note [Keeping implicitly quantified variables in+ order]).++Note [Kind generalisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Step 5 of Note [Recipe for checking a signature], namely+kind-generalisation, is done by+ kindGeneraliseAll+ kindGeneraliseSome+ kindGeneraliseNone++Here, we have to deal with the fact that metatyvars generated in the+type will have a bumped TcLevel, because explicit foralls raise the+TcLevel. To avoid these variables from ever being visible in the+surrounding context, we must obey the following dictum:+ Every metavariable in a type must either be (A) generalized, or (B) promoted, or See Note [Promotion in signatures]- (C) a cause to error See Note [Naughty quantification candidates] in GHC.Tc.Utils.TcMType+ (C) a cause to error See Note [Naughty quantification candidates]+ in GHC.Tc.Utils.TcMType +There are three steps (look at kindGeneraliseSome):++1. candidateQTyVarsOfType finds the free variables of the type or kind,+ to generalise++2. filterConstrainedCandidates filters out candidates that appear+ in the unsolved 'wanteds', and promotes the ones that get filtered out+ thereby.++3. quantifyTyVars quantifies the remaining type variables+ The kindGeneralize functions do not require pre-zonking; they zonk as they go. -If you are actually doing kind-generalization, you need to bump the level-before generating constraints, as we will only generalize variables with-a TcLevel higher than the ambient one.+kindGeneraliseAll specialises for the case where step (2) is vacuous.+kindGeneraliseNone specialises for the case where we do no quantification,+but we must still promote. -After promoting/generalizing, we need to zonk again because both-promoting and generalizing fill in metavariables.+If you are actually doing kind-generalization, you need to bump the+level before generating constraints, as we will only generalize+variables with a TcLevel higher than the ambient one.+Hence the "pushLevel" in pushLevelAndSolveEqualities. Note [Promotion in signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -301,10 +377,9 @@ kcClassSigType skol_info names (HsIB { hsib_ext = sig_vars , hsib_body = hs_ty }) = addSigCtxt (funsSigCtxt names) hs_ty $- do { (tc_lvl, (wanted, (spec_tkvs, _)))- <- pushTcLevelM $- solveLocalEqualitiesX "kcClassSigType" $- bindImplicitTKBndrs_Skol sig_vars $+ do { (tc_lvl, wanted, (spec_tkvs, _))+ <- pushLevelAndSolveEqualitiesX "kcClassSigType" $+ bindImplicitTKBndrs_Skol sig_vars $ tcLHsType hs_ty liftedTypeKind ; emitResidualTvConstraint skol_info spec_tkvs tc_lvl wanted }@@ -364,27 +439,19 @@ -- Returns also an implication for the unsolved constraints tc_hs_sig_type skol_info hs_sig_type ctxt_kind | HsIB { hsib_ext = sig_vars, hsib_body = hs_ty } <- hs_sig_type- = do { (tc_lvl, (wanted, (spec_tkvs, ty)))- <- pushTcLevelM $- solveLocalEqualitiesX "tc_hs_sig_type" $+ = do { (tc_lvl, wanted, (spec_tkvs, ty))+ <- pushLevelAndSolveEqualitiesX "tc_hs_sig_type" $ -- See Note [Failure in local type signatures] bindImplicitTKBndrs_Skol sig_vars $ do { kind <- newExpectedKind ctxt_kind ; tcLHsType hs_ty kind }- -- Any remaining variables (unsolved in the solveLocalEqualities)+ -- Any remaining variables (unsolved in the solveEqualities) -- should be in the global tyvars, and therefore won't be quantified ; spec_tkvs <- zonkAndScopedSort spec_tkvs ; let ty1 = mkSpecForAllTys spec_tkvs ty - -- This bit is very much like decideMonoTyVars in GHC.Tc.Solver,- -- but constraints are so much simpler in kinds, it is much- -- easier here. (In particular, we never quantify over a- -- constraint in a type.)- ; constrained <- zonkTyCoVarsAndFV (tyCoVarsOfWC wanted)- ; let should_gen = not . (`elemVarSet` constrained)-- ; kvs <- kindGeneralizeSome should_gen ty1+ ; kvs <- kindGeneralizeSome wanted ty1 -- Build an implication for any as-yet-unsolved kind equalities -- See Note [Skolem escape in type signatures]@@ -448,16 +515,18 @@ tc_top_lhs_type mode hs_sig_type ctxt_kind | HsIB { hsib_ext = sig_vars, hsib_body = hs_ty } <- hs_sig_type = do { traceTc "tcTopLHsType {" (ppr hs_ty)- ; (spec_tkvs, ty)- <- pushTcLevelM_ $- solveEqualities $- bindImplicitTKBndrs_Skol sig_vars $+ ; (tclvl, wanted, (spec_tkvs, ty))+ <- pushLevelAndSolveEqualitiesX "tc_top_lhs_type" $+ bindImplicitTKBndrs_Skol sig_vars $ do { kind <- newExpectedKind ctxt_kind ; tc_lhs_type mode hs_ty kind } ; spec_tkvs <- zonkAndScopedSort spec_tkvs+ ; reportUnsolvedEqualities InstSkol spec_tkvs tclvl wanted+ ; let ty1 = mkSpecForAllTys spec_tkvs ty- ; kvs <- kindGeneralizeAll ty1 -- "All" because it's a top-level type+ ; kvs <- kindGeneralizeAll ty1+ ; final_ty <- zonkTcTypeToType (mkInfForAllTys kvs ty1) ; traceTc "End tcTopLHsType }" (vcat [ppr hs_ty, ppr final_ty]) ; return final_ty}@@ -533,7 +602,7 @@ = do { mode <- mkHoleMode TypeLevel HM_VTA -- HM_VTA: See Note [Wildcards in visible type application] ; ty <- addTypeCtxt hs_ty $- solveLocalEqualities "tcHsTypeApp" $+ solveEqualities "tcHsTypeApp" $ -- We are looking at a user-written type, very like a -- signature so we want to solve its equalities right now tcNamedWildCardBinders sig_wcs $ \ _ ->@@ -985,8 +1054,9 @@ --------- Foralls tc_hs_type mode forall@(HsForAllTy { hst_tele = tele, hst_body = ty }) exp_kind = do { (tclvl, wanted, (tv_bndrs, ty'))- <- pushLevelAndCaptureConstraints $- bindExplicitTKTele_Skol_M mode tele $+ <- pushLevelAndCaptureConstraints $+ -- No need to solve equalities here; we will do that later+ bindExplicitTKTele_Skol_M mode tele $ -- The _M variant passes on the mode from the type, to -- any wildards in kind signatures on the forall'd variables -- e.g. f :: _ -> Int -> forall (a :: _). blah@@ -1000,22 +1070,15 @@ map ppr hs_tvs HsForAllInvis { hsf_invis_bndrs = hs_tvs } -> map ppr hs_tvs- tv_bndrs' = construct_bndrs tv_bndrs- skol_tvs = binderVars tv_bndrs'+ skol_tvs = binderVars tv_bndrs+ ; implic <- buildTvImplication skol_info skol_tvs tclvl wanted ; emitImplication implic -- /Always/ emit this implication even if wanted is empty -- We need the implication so that we check for a bad telescope -- See Note [Skolem escape and forall-types] - ; return (mkForAllTys tv_bndrs' ty') }- where- construct_bndrs :: Either [TcReqTVBinder] [TcInvisTVBinder]- -> [TcTyVarBinder]- construct_bndrs (Left req_tv_bndrs) =- map (mkTyVarBinder Required . binderVar) req_tv_bndrs- construct_bndrs (Right inv_tv_bndrs) =- map tyVarSpecToBinder inv_tv_bndrs+ ; return (mkForAllTys tv_bndrs ty') } tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = rn_ty }) exp_kind | null (unLoc ctxt)@@ -1269,8 +1332,8 @@ | arity > mAX_CTUPLE_SIZE -> failWith (bigConstraintTuple arity) | otherwise- -> do tycon <- tcLookupTyCon (cTupleTyConName arity)- check_expected_kind (mkTyConApp tycon tau_tys) constraintKind+ -> let tycon = cTupleTyCon arity in+ check_expected_kind (mkTyConApp tycon tau_tys) constraintKind BoxedTuple -> do let tycon = tupleTyCon Boxed arity checkWiredInTyCon tycon@@ -1798,11 +1861,9 @@ ; case thing of ATyVar _ tv -> return (mkTyVarTy tv, tyVarKind tv) + -- See Note [Recursion through the kinds] ATcTyCon tc_tc- -> do { -- See Note [GADT kind self-reference]- unless (isTypeLevel (mode_tyki mode))- (promotionErr name TyConPE)- ; check_tc tc_tc+ -> do { check_tc tc_tc ; return (mkTyConTy tc_tc, tyConKind tc_tc) } AGlobal (ATyCon tc)@@ -1843,26 +1904,35 @@ dc_theta_illegal_constraint = find (not . isEqPred) {--Note [GADT kind self-reference]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--A promoted type cannot be used in the body of that type's declaration.-#11554 shows this example, which made GHC loop:+Note [Recursion through the kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider these examples - import Data.Kind+#11554: data P (x :: k) = Q data A :: Type where- B :: forall (a :: A). P a -> A+ MkA :: forall (a :: A). P a -> A -In order to check the constructor B, we need to have the promoted type A, but in-order to get that promoted type, B must first be checked. To prevent looping, a-TyConPE promotion error is given when tcTyVar checks an ATcTyCon in kind mode.-Any ATcTyCon is a TyCon being defined in the current recursive group (see data-type decl for TcTyThing), and all such TyCons are illegal in kinds.+#12174+ data V a+ data T = forall (a :: T). MkT (V a) -#11962 proposes checking the head of a data declaration separately from-its constructors. This would allow the example above to pass.+The type is recursive (which is fine) but it is recursive /through the+kinds/. In earlier versions of GHC this caused a loop in the compiler+(to do with knot-tying) but there is nothing fundamentally wrong with+the code (kinds are types, and the recursive declarations are OK). But+it's hard to distinguish "recursion through the kinds" from "recursion+through the types". Consider this (also #11554): + data PB k (x :: k) = Q+ data B :: Type where+ MkB :: P B a -> B++Here the occurrence of B is not obviously in a kind position.++So now GHC allows all these programs. #12081 and #15942 are other+examples.+ Note [Body kind of a HsForAllTy] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The body of a forall is usually a type, but in principle@@ -2187,11 +2257,10 @@ -- CUSK case -- See note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl = addTyConFlavCtxt name flav $- do { (scoped_kvs, (tc_tvs, res_kind))- <- pushTcLevelM_ $- solveEqualities $- bindImplicitTKBndrs_Q_Skol kv_ns $- bindExplicitTKBndrs_Q_Skol ctxt_kind hs_tvs $+ do { (tclvl, wanted, (scoped_kvs, (tc_tvs, res_kind)))+ <- pushLevelAndSolveEqualitiesX "kcCheckDeclHeader_cusk" $+ bindImplicitTKBndrs_Q_Skol kv_ns $+ bindExplicitTKBndrs_Q_Skol ctxt_kind hs_tvs $ newExpectedKind =<< kc_res_ki -- Now, because we're in a CUSK,@@ -2227,6 +2296,10 @@ tycon = mkTcTyCon name final_tc_binders res_kind all_tv_prs True -- it is generalised flav++ ; reportUnsolvedEqualities skol_info (binderVars final_tc_binders)+ tclvl wanted+ -- If the ordering from -- Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl -- doesn't work, we catch it here, before an error cascade@@ -2249,6 +2322,7 @@ ; return tycon } where+ skol_info = TyConSkol flav name ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind | otherwise = AnyKind @@ -2351,11 +2425,10 @@ -- and to [(Name, TcTyVar)] for tcTyConScopedTyVars ; (vis_tcbs, concat -> explicit_tv_prs) <- mapAndUnzipM zipped_to_tcb zipped_binders - ; (implicit_tvs, (invis_binders, r_ki))- <- pushTcLevelM_ $- solveEqualities $ -- #16687- bindImplicitTKBndrs_Tv implicit_nms $- tcExtendNameTyVarEnv explicit_tv_prs $+ ; (tclvl, wanted, (implicit_tvs, (invis_binders, r_ki)))+ <- pushLevelAndSolveEqualitiesX "kcCheckDeclHeader_sig" $ -- #16687+ bindImplicitTKBndrs_Tv implicit_nms $+ tcExtendNameTyVarEnv explicit_tv_prs $ do { -- Check that inline kind annotations on binders are valid. -- For example: --@@ -2409,8 +2482,12 @@ ; let tcbs = vis_tcbs ++ invis_tcbs implicit_tv_prs = implicit_nms `zip` implicit_tvs all_tv_prs = implicit_tv_prs ++ explicit_tv_prs- tc = mkTcTyCon name tcbs r_ki all_tv_prs True flav+ tc = mkTcTyCon name tcbs r_ki all_tv_prs True flav+ skol_info = TyConSkol flav name + -- Check that there are no unsolved equalities+ ; reportUnsolvedEqualities skol_info (binderVars tcbs) tclvl wanted+ ; traceTc "kcCheckDeclHeader_sig done:" $ vcat [ text "tyConName = " <+> ppr (tyConName tc) , text "kisig =" <+> debugPprType kisig@@ -2499,7 +2576,7 @@ KindedTyVar _ _ v v_hs_ki -> do v_ki <- tcLHsKindSig (TyVarBndrKindCtxt (unLoc v)) v_hs_ki discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig]- unifyKind (Just (HsTyVar noExtField NotPromoted v))+ unifyKind (Just (ppr v)) (tyBinderType tb) v_ki @@ -2831,7 +2908,6 @@ -- Depending on the context, we might accept any kind (for instance, in a TH -- splice), or only certain kinds (like in type signatures). expectedKindInCtxt (TySynCtxt _) = AnyKind-expectedKindInCtxt ThBrackCtxt = AnyKind expectedKindInCtxt (GhciCtxt {}) = AnyKind -- The types in a 'default' decl can have varying kinds -- See Note [Extended defaults]" in GHC.Tc.Utils.Env@@ -2954,19 +3030,22 @@ -------------------------------------- -- | Skolemise the 'HsTyVarBndr's in an 'LHsForAllTelescope.--- Returns 'Left' for visible @forall@s and 'Right' for invisible @forall@s. bindExplicitTKTele_Skol_M :: TcTyMode -> HsForAllTelescope GhcRn -> TcM a- -> TcM (Either [TcReqTVBinder] [TcInvisTVBinder], a)+ -> TcM ([TcTyVarBinder], a) bindExplicitTKTele_Skol_M mode tele thing_inside = case tele of- HsForAllVis { hsf_vis_bndrs = bndrs } -> do- (req_tv_bndrs, thing) <- bindExplicitTKBndrs_Skol_M mode bndrs thing_inside- pure (Left req_tv_bndrs, thing)- HsForAllInvis { hsf_invis_bndrs = bndrs } -> do- (inv_tv_bndrs, thing) <- bindExplicitTKBndrs_Skol_M mode bndrs thing_inside- pure (Right inv_tv_bndrs, thing)+ HsForAllVis { hsf_vis_bndrs = bndrs }+ -> do { (req_tv_bndrs, thing) <- bindExplicitTKBndrs_Skol_M mode bndrs thing_inside+ -- req_tv_bndrs :: [VarBndr TyVar ()],+ -- but we want [VarBndr TyVar ArgFlag]+ ; return (tyVarReqToBinders req_tv_bndrs, thing) }+ HsForAllInvis { hsf_invis_bndrs = bndrs }+ -> do { (inv_tv_bndrs, thing) <- bindExplicitTKBndrs_Skol_M mode bndrs thing_inside+ -- inv_tv_bndrs :: [VarBndr TyVar Specificity],+ -- but we want [VarBndr TyVar ArgFlag]+ ; return (tyVarSpecToBinders inv_tv_bndrs, thing) } bindExplicitTKBndrs_Skol, bindExplicitTKBndrs_Tv :: (OutputableBndrFlag flag)@@ -3006,10 +3085,10 @@ -- with the passed-in [LHsTyVarBndr] bindExplicitTKBndrsX_Q tc_tv hs_tvs thing_inside = do { (tv_bndrs,res) <- bindExplicitTKBndrsX tc_tv hs_tvs thing_inside- ; return ((binderVars tv_bndrs),res) }+ ; return (binderVars tv_bndrs,res) } bindExplicitTKBndrsX :: (OutputableBndrFlag flag)- => (HsTyVarBndr flag GhcRn -> TcM TcTyVar)+ => (HsTyVarBndr flag GhcRn -> TcM TyVar) -> [LHsTyVarBndr flag GhcRn] -> TcM a -> TcM ([VarBndr TyVar flag], a) -- Returned [TcTyVar] are in 1-1 correspondence@@ -3029,7 +3108,7 @@ -- See GHC.Tc.Utils.TcMType Note [Cloning for tyvar binders] ; (tvs,res) <- tcExtendNameTyVarEnv [(hsTyVarName hs_tv, tv)] $ go hs_tvs- ; return ((Bndr tv (hsTyVarBndrFlag hs_tv)):tvs, res) }+ ; return (Bndr tv (hsTyVarBndrFlag hs_tv):tvs, res) } ----------------- tcHsTyVarBndr :: TcTyMode -> (Name -> Kind -> TcM TyVar)@@ -3060,7 +3139,7 @@ ; mb_tv <- tcLookupLcl_maybe tv_nm ; case mb_tv of Just (ATyVar _ tv)- -> do { discardResult $ unifyKind (Just hs_tv)+ -> do { discardResult $ unifyKind (Just (ppr tv_nm)) kind (tyVarKind tv) -- This unify rejects: -- class C (m :: * -> *) where@@ -3068,9 +3147,6 @@ ; return tv } _ -> new_tv tv_nm kind }- where- hs_tv = HsTyVar noExtField NotPromoted (noLoc tv_nm)- -- Used for error messages only -------------------------------------- -- Binding type/class variables in the@@ -3110,56 +3186,63 @@ -- | Generalize some of the free variables in the given type. -- All such variables should be *kind* variables; any type variables -- should be explicitly quantified (with a `forall`) before now.--- The supplied predicate says which free variables to quantify.--- But in all cases,--- generalize only those variables whose TcLevel is strictly greater--- than the ambient level. This "strictly greater than" means that--- you likely need to push the level before creating whatever type--- gets passed here. Any variable whose level is greater than the--- ambient level but is not selected to be generalized will be--- promoted. (See [Promoting unification variables] in "GHC.Tc.Solver"--- and Note [Recipe for checking a signature].)--- The resulting KindVar are the variables to--- quantify over, in the correct, well-scoped order. They should--- generally be Inferred, not Specified, but that's really up to--- the caller of this function.-kindGeneralizeSome :: (TcTyVar -> Bool)+--+-- The WantedConstraints are un-solved kind constraints. Generally+-- they'll be reported as errors later, but meanwhile we refrain+-- from quantifying over any variable free in these unsolved+-- constraints. See Note [Failure in local type signatures].+--+-- But in all cases, generalize only those variables whose TcLevel is+-- strictly greater than the ambient level. This "strictly greater+-- than" means that you likely need to push the level before creating+-- whatever type gets passed here.+--+-- Any variable whose level is greater than the ambient level but is+-- not selected to be generalized will be promoted. (See [Promoting+-- unification variables] in "GHC.Tc.Solver" and Note [Recipe for+-- checking a signature].)+--+-- The resulting KindVar are the variables to quantify over, in the+-- correct, well-scoped order. They should generally be Inferred, not+-- Specified, but that's really up to the caller of this function.+kindGeneralizeSome :: WantedConstraints -> TcType -- ^ needn't be zonked -> TcM [KindVar]-kindGeneralizeSome should_gen kind_or_type- = do { traceTc "kindGeneralizeSome {" (ppr kind_or_type)-- -- use the "Kind" variant here, as any types we see+kindGeneralizeSome wanted kind_or_type+ = do { -- Use the "Kind" variant here, as any types we see -- here will already have all type variables quantified; -- thus, every free variable is really a kv, never a tv. ; dvs <- candidateQTyVarsOfKind kind_or_type-- -- So 'dvs' are the variables free in kind_or_type, with a level greater- -- than the ambient level, hence candidates for quantification- -- Next: filter out the ones we don't want to generalize (specified by should_gen)- -- and promote them instead-- ; let (to_promote, dvs') = partitionCandidates dvs (not . should_gen)+ ; dvs <- filterConstrainedCandidates wanted dvs+ ; quantifyTyVars dvs } +filterConstrainedCandidates+ :: WantedConstraints -- Don't quantify over variables free in these+ -- Not necessarily fully zonked+ -> CandidatesQTvs -- Candidates for quantification+ -> TcM CandidatesQTvs+-- filterConstrainedCandidates removes any candidates that are free in+-- 'wanted'; instead, it promotes them. This bit is very much like+-- decideMonoTyVars in GHC.Tc.Solver, but constraints are so much+-- simpler in kinds, it is much easier here. (In particular, we never+-- quantify over a constraint in a type.)+filterConstrainedCandidates wanted dvs+ | isEmptyWC wanted -- Fast path for a common case+ = return dvs+ | otherwise+ = do { wc_tvs <- zonkTyCoVarsAndFV (tyCoVarsOfWC wanted)+ ; let (to_promote, dvs') = partitionCandidates dvs (`elemVarSet` wc_tvs) ; _ <- promoteTyVarSet to_promote- ; qkvs <- quantifyTyVars dvs'-- ; traceTc "kindGeneralizeSome }" $- vcat [ text "Kind or type:" <+> ppr kind_or_type- , text "dvs:" <+> ppr dvs- , text "dvs':" <+> ppr dvs'- , text "to_promote:" <+> ppr to_promote- , text "qkvs:" <+> pprTyVars qkvs ]-- ; return qkvs }+ ; return dvs' } --- | Specialized version of 'kindGeneralizeSome', but where all variables--- can be generalized. Use this variant when you can be sure that no more--- constraints on the type's metavariables will arise or be solved.-kindGeneralizeAll :: TcType -- needn't be zonked- -> TcM [KindVar]-kindGeneralizeAll ty = do { traceTc "kindGeneralizeAll" empty- ; kindGeneralizeSome (const True) ty }+-- |- Specialised verison of 'kindGeneralizeSome', but with empty+-- WantedConstraints, so no filtering is needed+-- i.e. kindGeneraliseAll = kindGeneralizeSome emptyWC+kindGeneralizeAll :: TcType -> TcM [KindVar]+kindGeneralizeAll kind_or_type+ = do { traceTc "kindGeneralizeAll" (ppr kind_or_type)+ ; dvs <- candidateQTyVarsOfKind kind_or_type+ ; quantifyTyVars dvs } -- | Specialized version of 'kindGeneralizeSome', but where no variables -- can be generalized, but perhaps some may neeed to be promoted.@@ -3171,11 +3254,11 @@ -- Note [Promotion in signatures]. kindGeneralizeNone :: TcType -- needn't be zonked -> TcM ()-kindGeneralizeNone ty- = do { traceTc "kindGeneralizeNone" empty- ; kvs <- kindGeneralizeSome (const False) ty- ; MASSERT( null kvs )- }+kindGeneralizeNone kind_or_type+ = do { traceTc "kindGeneralizeNone" (ppr kind_or_type)+ ; dvs <- candidateQTyVarsOfKind kind_or_type+ ; _ <- promoteTyVarSet (candidateKindVars dvs)+ ; return () } {- Note [Levels and generalisation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -3502,10 +3585,10 @@ = addSigCtxt ctxt hs_ty $ do { mode <- mkHoleMode TypeLevel HM_Sig ; (implicit_tvs, (explicit_tvbndrs, (wcs, wcx, theta, tau)))- <- solveLocalEqualities "tcHsPartialSigType" $+ <- solveEqualities "tcHsPartialSigType" $ -- See Note [Failure in local type signatures]- tcNamedWildCardBinders sig_wcs $ \ wcs ->- bindImplicitTKBndrs_Tv implicit_hs_tvs $+ tcNamedWildCardBinders sig_wcs $ \ wcs ->+ bindImplicitTKBndrs_Tv implicit_hs_tvs $ bindExplicitTKBndrs_Tv_M mode explicit_hs_tvs $ do { -- Instantiate the type-class context; but if there -- is an extra-constraints wildcard, just discard it here@@ -3712,11 +3795,11 @@ do { sig_tkv_prs <- mapM new_implicit_tv sig_ns ; mode <- mkHoleMode TypeLevel HM_Sig ; (wcs, sig_ty)- <- addTypeCtxt hs_ty $- solveLocalEqualities "tcHsPatSigType" $+ <- addTypeCtxt hs_ty $+ solveEqualities "tcHsPatSigType" $ -- See Note [Failure in local type signatures] -- and c.f #16033- tcNamedWildCardBinders sig_wcs $ \ wcs ->+ tcNamedWildCardBinders sig_wcs $ \ wcs -> tcExtendNameTyVarEnv sig_tkv_prs $ do { ek <- newOpenTypeKind ; sig_ty <- tc_lhs_type mode hs_ty ek@@ -3762,7 +3845,7 @@ It must be a skolem so that it retains its identity, and GHC.Tc.Errors.getSkolemInfo can thereby find the binding site for the skolem. - * The type signature pattern (f :: b -> c) makes freshs meta-tyvars+ * The type signature pattern (f :: b -> c) makes fresh meta-tyvars beta and gamma (TauTvs), and binds "b" :-> beta, "c" :-> gamma in the environment @@ -3790,7 +3873,7 @@ RULE "foo" forall (x::a) (y::[a]). f x y = ... Here this really is the binding site of the type variable so we'd like to use a skolem, so that we get a complaint if we unify two of them-together. Hence the new_tv function in tcHsPatSigType.+together. Hence the new_implicit_tv function in tcHsPatSigType. ************************************************************************@@ -3829,7 +3912,7 @@ -- See Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType -- Result is zonked = do { kind <- addErrCtxt (text "In the kind" <+> quotes (ppr hs_kind)) $- solveLocalEqualities "tcLHsKindSig" $+ solveEqualities "tcLHsKindSig" $ tc_lhs_type mode hs_kind liftedTypeKind ; traceTc "tcLHsKindSig" (ppr hs_kind $$ ppr kind) -- No generalization:@@ -3869,19 +3952,6 @@ ************************************************************************ -} ---- | If the inner action emits constraints, report them as errors and fail;--- otherwise, propagates the return value. Useful as a wrapper around--- 'tcImplicitTKBndrs', which uses solveLocalEqualities, when there won't be--- another chance to solve constraints-failIfEmitsConstraints :: TcM a -> TcM a-failIfEmitsConstraints thing_inside- = checkNoErrs $ -- We say that we fail if there are constraints!- -- c.f same checkNoErrs in solveEqualities- do { (res, lie) <- captureConstraints thing_inside- ; reportAllUnsolved lie- ; return res- } -- | Make an appropriate message for an error in a function argument. -- Used for both expressions and types.
compiler/GHC/Tc/Gen/Match.hs view
@@ -39,13 +39,14 @@ import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcInferRho, tcInferRhoNC , tcMonoExpr, tcMonoExprNC, tcExpr , tcCheckMonoExpr, tcCheckMonoExprNC- , tcCheckPolyExpr, tcCheckId )+ , tcCheckPolyExpr ) import GHC.Types.Basic (LexicalFixity(..)) import GHC.Hs import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env import GHC.Tc.Gen.Pat+import GHC.Tc.Gen.Head( tcCheckId ) import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType import GHC.Tc.Gen.Bind@@ -396,7 +397,14 @@ ; return (BodyStmt boolTy guard' noSyntaxExpr noSyntaxExpr, thing) } tcGuardStmt ctxt (BindStmt _ pat rhs) res_ty thing_inside- = do { (rhs', rhs_ty) <- tcInferRhoNC rhs+ = do { -- The Many on the next line and the unrestricted on the line after+ -- are linked. These must be the same multiplicity. Consider+ -- x <- rhs -> u+ --+ -- The multiplicity of x in u must be the same as the multiplicity at+ -- which the rhs has been consumed. When solving #18738, we want these+ -- two multiplicity to still be the same.+ (rhs', rhs_ty) <- tcScalingUsage Many $ tcInferRhoNC rhs -- Stmt has a context already ; (pat', thing) <- tcCheckPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs) pat (unrestricted rhs_ty) $
compiler/GHC/Tc/Gen/Pat.hs view
@@ -426,10 +426,9 @@ -- Note [View patterns and polymorphism] -- Expression must be a function- ; let expr_orig = lexprCtOrigin expr- herald = text "A view pattern expression expects"+ ; let herald = text "A view pattern expression expects" ; (expr_wrap1, Scaled _mult inf_arg_ty, inf_res_sigma)- <- matchActualFunTySigma herald expr_orig (Just (unLoc expr)) (1,[]) expr_ty+ <- matchActualFunTySigma herald (Just (ppr expr)) (1,[]) expr_ty -- See Note [View patterns and polymorphism] -- expr_wrap1 :: expr_ty "->" (inf_arg_ty -> inf_res_sigma)
compiler/GHC/Tc/Gen/Sig.hs view
@@ -14,7 +14,7 @@ TcSigFun, isPartialSig, hasCompleteSig, tcIdSigName, tcSigInfoName,- completeSigPolyId_maybe,+ completeSigPolyId_maybe, isCompleteHsSig, tcTySigs, tcUserTypeSig, completeSigFromId, tcInstSig,@@ -30,6 +30,7 @@ import GHC.Hs import GHC.Tc.Gen.HsType import GHC.Tc.Types+import GHC.Tc.Solver( pushLevelAndSolveEqualitiesX, reportUnsolvedEqualities ) import GHC.Tc.Utils.Monad import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType@@ -55,7 +56,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Types.SrcLoc-import GHC.Utils.Misc( singleton )+import GHC.Utils.Misc as Utils ( singleton ) import GHC.Data.Maybe( orElse ) import Data.Maybe( mapMaybe ) import Control.Monad( unless )@@ -360,23 +361,18 @@ * After we kind-check the pieces and convert to Types, we do kind generalisation. -Note [solveEqualities in tcPatSynSig]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [Report unsolved equalities in tcPatSynSig]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It's important that we solve /all/ the equalities in a pattern synonym signature, because we are going to zonk the signature to a Type (not a TcType), in GHC.Tc.TyCl.PatSyn.tc_patsyn_finish, and that fails if there are un-filled-in coercion variables mentioned in the type (#15694). -The best thing is simply to use solveEqualities to solve all the-equalites, rather than leaving them in the ambient constraints-to be solved later. Pattern synonyms are top-level, so there's-no problem with completely solving them.--(NB: this solveEqualities wraps newImplicitTKBndrs, which itself-does a solveLocalEqualities; so solveEqualities isn't going to-make any further progress; it'll just report any unsolved ones,-and fail, as it should.)+So we solve all the equalities we can, and report any unsolved ones,+rather than leaving them in the ambient constraints to be solved+later. Pattern synonyms are top-level, so there's no problem with+completely solving them. -} tcPatSynSig :: Name -> LHsSigType GhcRn -> TcM TcPatSynInfo@@ -388,12 +384,11 @@ , (univ_hs_tvbndrs, hs_req, hs_ty1) <- splitLHsSigmaTyInvis hs_ty , (ex_hs_tvbndrs, hs_prov, hs_body_ty) <- splitLHsSigmaTyInvis hs_ty1 = do { traceTc "tcPatSynSig 1" (ppr sig_ty)- ; (implicit_tvs, (univ_tvbndrs, (ex_tvbndrs, (req, prov, body_ty))))- <- pushTcLevelM_ $- solveEqualities $ -- See Note [solveEqualities in tcPatSynSig]- bindImplicitTKBndrs_Skol implicit_hs_tvs $- bindExplicitTKBndrs_Skol univ_hs_tvbndrs $- bindExplicitTKBndrs_Skol ex_hs_tvbndrs $+ ; (tclvl, wanted, (implicit_tvs, (univ_tvbndrs, (ex_tvbndrs, (req, prov, body_ty)))))+ <- pushLevelAndSolveEqualitiesX "tcPatSynSig" $+ bindImplicitTKBndrs_Skol implicit_hs_tvs $+ bindExplicitTKBndrs_Skol univ_hs_tvbndrs $+ bindExplicitTKBndrs_Skol ex_hs_tvbndrs $ do { req <- tcHsContext hs_req ; prov <- tcHsContext hs_prov ; body_ty <- tcHsOpenType hs_body_ty@@ -401,6 +396,7 @@ -- e.g. pattern Zero <- 0# (#12094) ; return (req, prov, body_ty) } + ; implicit_tvs <- zonkAndScopedSort implicit_tvs ; let ungen_patsyn_ty = build_patsyn_type [] implicit_tvs univ_tvbndrs req ex_tvbndrs prov body_ty @@ -408,61 +404,46 @@ ; kvs <- kindGeneralizeAll ungen_patsyn_ty ; traceTc "tcPatSynSig" (ppr ungen_patsyn_ty) + ; let skol_tvs = kvs ++ implicit_tvs ++ binderVars (univ_tvbndrs ++ ex_tvbndrs)+ skol_info = DataConSkol name+ ; reportUnsolvedEqualities skol_info skol_tvs tclvl wanted+ -- See Note [Report unsolved equalities in tcPatSynSig]+ -- These are /signatures/ so we zonk to squeeze out any kind- -- unification variables. Do this after kindGeneralize which may+ -- unification variables. Do this after kindGeneralizeAll which may -- default kind variables to *.- ; implicit_tvs <- zonkAndScopedSort implicit_tvs+ ; implicit_tvs <- mapM zonkTcTyVarToTyVar implicit_tvs ; univ_tvbndrs <- mapM zonkTyCoVarKindBinder univ_tvbndrs ; ex_tvbndrs <- mapM zonkTyCoVarKindBinder ex_tvbndrs ; req <- zonkTcTypes req ; prov <- zonkTcTypes prov ; body_ty <- zonkTcType body_ty - -- Skolems have TcLevels too, though they're used only for debugging.- -- If you don't do this, the debugging checks fail in GHC.Tc.TyCl.PatSyn.- -- Test case: patsyn/should_compile/T13441-{-- ; tclvl <- getTcLevel- ; let env0 = mkEmptyTCvSubst $ mkInScopeSet $ mkVarSet kvs- (env1, implicit_tvs') = promoteSkolemsX tclvl env0 implicit_tvs- (env2, univ_tvs') = promoteSkolemsX tclvl env1 univ_tvs- (env3, ex_tvs') = promoteSkolemsX tclvl env2 ex_tvs- req' = substTys env3 req- prov' = substTys env3 prov- body_ty' = substTy env3 body_ty--}- ; let implicit_tvs' = implicit_tvs- univ_tvbndrs' = univ_tvbndrs- ex_tvbndrs' = ex_tvbndrs- req' = req- prov' = prov- body_ty' = body_ty- -- Now do validity checking ; checkValidType ctxt $- build_patsyn_type kvs implicit_tvs' univ_tvbndrs' req' ex_tvbndrs' prov' body_ty'+ build_patsyn_type kvs implicit_tvs univ_tvbndrs req ex_tvbndrs prov body_ty -- arguments become the types of binders. We thus cannot allow -- levity polymorphism here- ; let (arg_tys, _) = tcSplitFunTys body_ty'+ ; let (arg_tys, _) = tcSplitFunTys body_ty ; mapM_ (checkForLevPoly empty . scaledThing) arg_tys ; traceTc "tcTySig }" $- vcat [ text "implicit_tvs" <+> ppr_tvs implicit_tvs'+ vcat [ text "implicit_tvs" <+> ppr_tvs implicit_tvs , text "kvs" <+> ppr_tvs kvs- , text "univ_tvs" <+> ppr_tvs (binderVars univ_tvbndrs')- , text "req" <+> ppr req'- , text "ex_tvs" <+> ppr_tvs (binderVars ex_tvbndrs')- , text "prov" <+> ppr prov'- , text "body_ty" <+> ppr body_ty' ]+ , text "univ_tvs" <+> ppr_tvs (binderVars univ_tvbndrs)+ , text "req" <+> ppr req+ , text "ex_tvs" <+> ppr_tvs (binderVars ex_tvbndrs)+ , text "prov" <+> ppr prov+ , text "body_ty" <+> ppr body_ty ] ; return (TPSI { patsig_name = name , patsig_implicit_bndrs = mkTyVarBinders InferredSpec kvs ++- mkTyVarBinders SpecifiedSpec implicit_tvs'- , patsig_univ_bndrs = univ_tvbndrs'- , patsig_req = req'- , patsig_ex_bndrs = ex_tvbndrs'- , patsig_prov = prov'- , patsig_body_ty = body_ty' }) }+ mkTyVarBinders SpecifiedSpec implicit_tvs+ , patsig_univ_bndrs = univ_tvbndrs+ , patsig_req = req+ , patsig_ex_bndrs = ex_tvbndrs+ , patsig_prov = prov+ , patsig_body_ty = body_ty }) } where ctxt = PatSynCtxt name @@ -554,7 +535,7 @@ lookupPragEnv prag_fn n = lookupNameEnv prag_fn n `orElse` [] extendPragEnv :: TcPragEnv -> (Name, LSig GhcRn) -> TcPragEnv-extendPragEnv prag_fn (n, sig) = extendNameEnv_Acc (:) singleton prag_fn n sig+extendPragEnv prag_fn (n, sig) = extendNameEnv_Acc (:) Utils.singleton prag_fn n sig --------------- mkPragEnv :: [LSig GhcRn] -> LHsBinds GhcRn -> TcPragEnv
compiler/GHC/Tc/Gen/Splice.hs view
@@ -1435,11 +1435,17 @@ rnImplicitBndrs Nothing tv_rdrs $ \ tv_names -> do { (rn_ty, fvs) <- rnLHsType doc rdr_ty ; return ((tv_names, rn_ty), fvs) }- ; (_tvs, ty)- <- pushTcLevelM_ $- solveEqualities $ -- Avoid error cascade if there are unsolved- bindImplicitTKBndrs_Skol tv_names $++ ; (tclvl, wanted, (tvs, ty))+ <- pushLevelAndSolveEqualitiesX "reifyInstances" $+ bindImplicitTKBndrs_Skol tv_names $ tcInferLHsType rn_ty++ ; tvs <- zonkAndScopedSort tvs++ -- Avoid error cascade if there are unsolved+ ; reportUnsolvedEqualities ReifySkol tvs tclvl wanted+ ; ty <- zonkTcTypeToType ty -- Substitute out the meta type variables -- In particular, the type might have kind
compiler/GHC/Tc/Instance/Class.hs view
@@ -388,10 +388,9 @@ | Just (_, co_dict) <- tcInstNewTyCon_maybe (classTyCon clas) [ty] -- co_dict :: KnownNat n ~ SNat n , [ meth ] <- classMethods clas- , Just tcRep <- tyConAppTyCon_maybe -- SNat- $ funResultTy -- SNat n- $ dropForAlls -- KnownNat n => SNat n- $ idType meth -- forall n. KnownNat n => SNat n+ , Just tcRep <- tyConAppTyCon_maybe (classMethodTy meth)+ -- If the method type is forall n. KnownNat n => SNat n+ -- then tcRep is SNat , Just (_, co_rep) <- tcInstNewTyCon_maybe tcRep [ty] -- SNat n ~ Integer , let ev_tm = mkEvCast et (mkTcSymCo (mkTcTransCo co_dict co_rep))
compiler/GHC/Tc/Module.hs view
@@ -65,14 +65,17 @@ import GHC.Driver.Plugins import GHC.Driver.Session import GHC.Hs-import GHC.Iface.Syntax ( ShowSub(..), showToHeader )-import GHC.Iface.Type ( ShowForAllFlag(..) )-import GHC.Core.PatSyn( pprPatSynType )+import GHC.Iface.Syntax ( ShowSub(..), showToHeader )+import GHC.Iface.Type ( ShowForAllFlag(..) )+import GHC.Core.PatSyn ( pprPatSynType )+import GHC.Core.Predicate ( classMethodTy ) import GHC.Builtin.Names import GHC.Builtin.Utils import GHC.Types.Name.Reader import GHC.Tc.Utils.Zonk import GHC.Tc.Gen.Expr+import GHC.Tc.Errors( reportAllUnsolved )+import GHC.Tc.Gen.App( tcInferSigma ) import GHC.Tc.Utils.Monad import GHC.Tc.Gen.Export import GHC.Tc.Types.Evidence@@ -98,6 +101,7 @@ import GHC.IfaceToCore import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType+import GHC.Tc.Utils.Instantiate (tcGetInsts) import GHC.Tc.Solver import GHC.Tc.TyCl import GHC.Tc.Instance.Typeable ( mkTypeableBinds )@@ -135,7 +139,6 @@ import GHC.Data.Maybe import GHC.Utils.Misc import GHC.Data.Bag-import GHC.Tc.Utils.Instantiate (tcGetInsts) import qualified GHC.LanguageExtensions as LangExt import Data.Data ( Data ) import GHC.Hs.Dump@@ -1014,10 +1017,8 @@ name2 = idName id2 pname1 = quotes (ppr name1) pname2 = quotes (ppr name2)- (_, rho_ty1) = splitForAllTys (idType id1)- op_ty1 = funResultTy rho_ty1- (_, rho_ty2) = splitForAllTys (idType id2)- op_ty2 = funResultTy rho_ty2+ op_ty1 = classMethodTy id1+ op_ty2 = classMethodTy id2 eqAT (ATI tc1 def_ats1) (ATI tc2 def_ats2) = checkBootTyCon is_boot tc1 tc2 `andThenCheck`@@ -2479,9 +2480,9 @@ Nothing -> failWithTc $ text ("Can't find type:" ++ ty) -- | How should we infer a type? See Note [TcRnExprMode]-data TcRnExprMode = TM_Inst -- ^ Instantiate the type fully (:type)- | TM_NoInst -- ^ Do not instantiate the type (:type +v)- | TM_Default -- ^ Default the type eagerly (:type +d)+data TcRnExprMode = TM_Inst -- ^ Instantiate inferred quantifiers only (:type)+ | TM_Default -- ^ Instantiate all quantifiers,+ -- and do eager defaulting (:type +d) -- | tcRnExpr just finds the type of an expression -- for :type@@ -2496,16 +2497,15 @@ (rn_expr, _fvs) <- rnLExpr rdr_expr ; failIfErrsM ; - -- Now typecheck the expression, and generalise its type- -- it might have a rank-2 type (e.g. :t runST)- uniq <- newUnique ;- let { fresh_it = itName uniq (getLoc rdr_expr) } ;- ((tclvl, (_tc_expr, res_ty)), lie)+ -- Typecheck the expression+ ((tclvl, res_ty), lie) <- captureTopConstraints $ pushTcLevelM $- tc_infer rn_expr ;+ tcInferSigma inst rn_expr ; -- Generalise+ uniq <- newUnique ;+ let { fresh_it = itName uniq (getLoc rdr_expr) } ; (qtvs, dicts, _, residual, _) <- simplifyInfer tclvl infer_mode [] {- No sig vars -}@@ -2529,14 +2529,10 @@ return (snd (normaliseType fam_envs Nominal ty)) } where- tc_infer expr | inst = tcInferRho expr- | otherwise = tcInferSigma expr- -- tcInferSigma: see Note [Implementing :type]-+ -- Optionally instantiate the type of the expression -- See Note [TcRnExprMode] (inst, infer_mode, perhaps_disable_default_warnings) = case mode of- TM_Inst -> (True, NoRestrictions, id)- TM_NoInst -> (False, NoRestrictions, id)+ TM_Inst -> (False, NoRestrictions, id) TM_Default -> (True, EagerDefaulting, unsetWOptM Opt_WarnTypeDefaults) {- Note [Implementing :type]@@ -2593,18 +2589,18 @@ -- It can have any rank or kind -- First bring into scope any wildcards ; traceTc "tcRnType" (vcat [ppr wcs, ppr rn_type])- ; (ty, kind) <- pushTcLevelM_ $- -- must push level to satisfy level precondition of- -- kindGeneralize, below- solveEqualities $- tcNamedWildCardBinders wcs $ \ wcs' ->- do { mapM_ emitNamedTypeHole wcs'- ; tcInferLHsTypeUnsaturated rn_type }+ ; (_tclvl, wanted, (ty, kind))+ <- pushLevelAndSolveEqualitiesX "tcRnType" $+ tcNamedWildCardBinders wcs $ \ wcs' ->+ do { mapM_ emitNamedTypeHole wcs'+ ; tcInferLHsTypeUnsaturated rn_type } + ; checkNoErrs (reportAllUnsolved wanted)+ -- Do kind generalisation; see Note [Kind-generalise in tcRnType] ; kvs <- kindGeneralizeAll kind- ; e <- mkEmptyZonkEnv flexi + ; e <- mkEmptyZonkEnv flexi ; ty <- zonkTcTypeToTypeX e ty -- Do validity checking on type@@ -2619,35 +2615,24 @@ ; return (ty', mkInfForAllTys kvs (tcTypeKind ty')) } + {- Note [TcRnExprMode] ~~~~~~~~~~~~~~~~~~~~~~ How should we infer a type when a user asks for the type of an expression e-at the GHCi prompt? We offer 3 different possibilities, described below. Each-considers this example, with -fprint-explicit-foralls enabled:-- foo :: forall a f b. (Show a, Num b, Foldable f) => a -> f b -> String- :type{,-spec,-def} foo @Int+at the GHCi prompt? We offer 2 different possibilities, described below. Each+considers this example, with -fprint-explicit-foralls enabled. See also+https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0179-printing-foralls.rst :type / TM_Inst - In this mode, we report the type that would be inferred if a variable- were assigned to expression e, without applying the monomorphism restriction.- This means we instantiate the type and then regeneralize, as discussed- in #11376.-- > :type foo @Int- forall {b} {f :: * -> *}. (Foldable f, Num b) => Int -> f b -> String-- Note that the variables and constraints are reordered here, because this- is possible during regeneralization. Also note that the variables are- reported as Inferred instead of Specified.--:type +v / TM_NoInst+ In this mode, we report the type obained by instantiating only the+ /inferred/ quantifiers of e's type, solving constraints, and+ re-generalising, as discussed in #11376. - This mode is for the benefit of users using TypeApplications. It does no- instantiation whatsoever, sometimes meaning that class constraints are not- solved.+ > :type reverse+ reverse :: forall a. [a] -> [a] + -- foo :: forall a f b. (Show a, Num b, Foldable f) => a -> f b -> String > :type +v foo @Int forall f b. (Show Int, Num b, Foldable f) => Int -> f b -> String @@ -2656,12 +2641,17 @@ :type +d / TM_Default - This mode is for the benefit of users who wish to see instantiations of- generalized types, and in particular to instantiate Foldable and Traversable.- In this mode, any type variable that can be defaulted is defaulted. Because- GHCi uses -XExtendedDefaultRules, this means that Foldable and Traversable are+ This mode is for the benefit of users who wish to see instantiations+ of generalized types, and in particular to instantiate Foldable and+ Traversable. In this mode, all type variables (inferred or+ specified) are instantiated. Because GHCi uses+ -XExtendedDefaultRules, this means that Foldable and Traversable are defaulted. + > :type +d reverse+ reverse :: forall {a}. [a] -> [a]++ -- foo :: forall a f b. (Show a, Num b, Foldable f) => a -> f b -> String > :type +d foo @Int Int -> [Integer] -> String @@ -2676,6 +2666,10 @@ type in the defaulting list that is both Num and Monoid. (If this list is modified to include an element that is both Num and Monoid, the defaulting would succeed, of course.)++ Note that the variables and constraints are reordered here, because this+ is possible during regeneralization. Also note that the variables are+ reported as Inferred instead of Specified. Note [Kind-generalise in tcRnType] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Tc/Solver.hs view
@@ -7,14 +7,16 @@ simplifyDefault, simplifyTop, simplifyTopImplic, simplifyInteractive,- solveEqualities, solveLocalEqualities, solveLocalEqualitiesX,+ solveEqualities,+ pushLevelAndSolveEqualities, pushLevelAndSolveEqualitiesX,+ reportUnsolvedEqualities, simplifyWantedsTcM, tcCheckSatisfiability, tcNormalise, captureTopConstraints, - simpl_top,+ simplifyTopWanteds, promoteTyVarSet, emitFlatConstraints, @@ -42,8 +44,9 @@ import GHC.Tc.Solver.Interact import GHC.Tc.Solver.Canonical ( makeSuperClasses, solveCallStack ) import GHC.Tc.Solver.Flatten ( flattenType )-import GHC.Tc.Utils.TcMType as TcM-import GHC.Tc.Utils.Monad as TcM+import GHC.Tc.Utils.Unify ( buildTvImplication )+import GHC.Tc.Utils.TcMType as TcM+import GHC.Tc.Utils.Monad as TcM import GHC.Tc.Solver.Monad as TcS import GHC.Tc.Types.Constraint import GHC.Core.Predicate@@ -56,7 +59,6 @@ import GHC.Utils.Panic import GHC.Types.Var import GHC.Types.Var.Set-import GHC.Types.Unique.Set import GHC.Types.Basic ( IntWithInf, intGtLimit ) import GHC.Utils.Error ( emptyMessages ) import qualified GHC.LanguageExtensions as LangExt@@ -85,7 +87,7 @@ -- -- Importantly, if captureTopConstraints propagates an exception, it -- reports any insoluble constraints first, lest they be lost--- altogether. This is important, because solveLocalEqualities (maybe+-- altogether. This is important, because solveEqualities (maybe -- other things too) throws an exception without adding any error -- messages; it just puts the unsolved constraints back into the -- monad. See GHC.Tc.Utils.Monad Note [Constraints and errors]@@ -129,7 +131,7 @@ simplifyTop wanteds = do { traceTc "simplifyTop {" $ text "wanted = " <+> ppr wanteds ; ((final_wc, unsafe_ol), binds1) <- runTcS $- do { final_wc <- simpl_top wanteds+ do { final_wc <- simplifyTopWanteds wanteds ; unsafe_ol <- getSafeOverlapFailures ; return (final_wc, unsafe_ol) } ; traceTc "End simplifyTop }" empty@@ -155,16 +157,54 @@ ; return (evBindMapBinds binds1 `unionBags` binds2) } +pushLevelAndSolveEqualities :: SkolemInfo -> [TcTyVar] -> TcM a -> TcM a+-- Push level, and solve all resulting equalities+-- If there are any unsolved equalities, report them+-- and fail (in the monad)+--+-- Panics if we solve any non-equality constraints. (In runTCSEqualities+-- we use an error thunk for the evidence bindings.)+pushLevelAndSolveEqualities skol_info skol_tvs thing_inside+ = do { (tclvl, wanted, res) <- pushLevelAndSolveEqualitiesX+ "pushLevelAndSolveEqualities" thing_inside+ ; reportUnsolvedEqualities skol_info skol_tvs tclvl wanted+ ; return res } +pushLevelAndSolveEqualitiesX :: String -> TcM a+ -> TcM (TcLevel, WantedConstraints, a)+-- Push the level, gather equality constraints, and then solve them.+-- Returns any remaining unsolved equalities.+-- Does not report errors.+--+-- Panics if we solve any non-equality constraints. (In runTCSEqualities+-- we use an error thunk for the evidence bindings.)+pushLevelAndSolveEqualitiesX callsite thing_inside+ = do { traceTc "pushLevelAndSolveEqualitiesX {" (text "Called from" <+> text callsite)+ ; (tclvl, (wanted, res))+ <- pushTcLevelM $+ do { (res, wanted) <- captureConstraints thing_inside+ ; wanted <- runTcSEqualities (simplifyTopWanteds wanted)+ ; return (wanted,res) }+ ; traceTc "pushLevelAndSolveEqualities }" (vcat [ text "Residual:" <+> ppr wanted+ , text "Level:" <+> ppr tclvl ])+ ; return (tclvl, wanted, res) }+ -- | Type-check a thing that emits only equality constraints, solving any--- constraints we can and re-emitting constraints that we can't. The thing_inside--- should generally bump the TcLevel to make sure that this run of the solver--- doesn't affect anything lying around.-solveLocalEqualities :: String -> TcM a -> TcM a--- Note [Failure in local type signatures]-solveLocalEqualities callsite thing_inside- = do { (wanted, res) <- solveLocalEqualitiesX callsite thing_inside- ; emitFlatConstraints wanted+-- constraints we can and re-emitting constraints that we can't.+-- Use this variant only when we'll get another crack at it later+-- See Note [Failure in local type signatures]+--+-- Panics if we solve any non-equality constraints. (In runTCSEqualities+-- we use an error thunk for the evidence bindings.)+solveEqualities :: String -> TcM a -> TcM a+solveEqualities callsite thing_inside+ = do { traceTc "solveEqualities {" (text "Called from" <+> text callsite)+ ; (res, wanted) <- captureConstraints thing_inside+ ; residual_wanted <- runTcSEqualities (solveWantedsAndDrop wanted)+ ; emitFlatConstraints residual_wanted+ -- emitFlatConstraints fails outright unless the only unsolved+ -- constraints are soluble-looking equalities that can float out+ ; traceTc "solveEqualities }" (text "Residual: " <+> ppr residual_wanted) ; return res } emitFlatConstraints :: WantedConstraints -> TcM ()@@ -176,7 +216,7 @@ ; emitConstraints wanted -- So they get reported! ; failM } Just (simples, holes)- -> do { _ <- promoteTyVarSet (tyCoVarsOfCts simples)+ -> do { _ <- TcM.promoteTyVarSet (tyCoVarsOfCts simples) ; traceTc "emitFlatConstraints:" $ vcat [ text "simples:" <+> ppr simples , text "holes: " <+> ppr holes ]@@ -226,11 +266,22 @@ {- Note [Failure in local type signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When kind checking a type signature, we like to fail fast if we can't-solve all the kind equality constraints: see Note [Fail fast on kind-errors]. But what about /local/ type signatures, mentioning in-scope-type variables for which there might be given equalities. Here's-an example (T15076b):+solve all the kind equality constraints, for two reasons: + * A kind-bogus type signature may cause a cascade of knock-on+ errors if we let it pass++ * More seriously, we don't have a convenient term-level place to add+ deferred bindings for unsolved kind-equality constraints. In+ earlier GHCs this led to un-filled-in coercion holes, which caused+ GHC to crash with "fvProv falls into a hole" See #11563, #11520,+ #11516, #11399++But what about /local/ type signatures, mentioning in-scope type+variables for which there might be 'given' equalities? For these we+might not be able to solve all the equalities locally. Here's an+example (T15076b):+ class (a ~ b) => C a b data SameKind :: k -> k -> Type where { SK :: SameKind a b } @@ -238,7 +289,7 @@ C a b => Proxy a -> Proxy b -> () bar _ _ = const () (undefined :: forall (x :: a) (y :: b). SameKind x y) -Consider the type singature on 'undefined'. It's ill-kinded unless+Consider the type signature on 'undefined'. It's ill-kinded unless a~b. But the superclass of (C a b) means that indeed (a~b). So all should be well. BUT it's hard to see that when kind-checking the signature for undefined. We want to emit a residual (a~b) constraint, to solve@@ -264,14 +315,16 @@ co1 and co2 with coercions involving 'a' and 'b' -- but by now we've instantiated the type. Chaos! -Moreover, the unsolved constraints might be skolem-escpae things, and+Moreover, the unsolved constraints might be skolem-escape things, and if we proceed with f bound to a nonsensical type, we get a cascade of follow-up errors. For example polykinds/T12593, T15577, and many others. -So here's the plan:+So here's the plan (see tcHsSigType): -* solveLocalEqualitiesX: try to solve the constraints (solveLocalEqualitiesX)+* pushLevelAndSolveEqualitiesX: try to solve the constraints +* kindGeneraliseSome: do kind generalisation+ * buildTvImplication: build an implication for the residual, unsolved constraint @@ -292,54 +345,49 @@ All this is done: -* in solveLocalEqualities, where there is no kind-generalisation- to complicate matters.+* In GHC.Tc.Gen.HsType.tcHsSigType, as above -* in GHC.Tc.Gen.HsType.tcHsSigType, where quantification intervenes.+* solveEqualities. Use this when there no kind-generalisation+ step to complicate matters; then we don't need to push levels,+ and can solve the equalities immediately without needing to+ wrap it in an implication constraint. (You'll generally see+ a kindGeneraliseNone nearby.) +* In GHC.Tc.TyCl and GHC.Tc.TyCl.Instance; see calls to+ pushLevelAndSolveEqualitiesX, followed by quantification, and+ then reportUnsolvedEqualities.++ NB: we call reportUnsolvedEqualities before zonkTcTypeToType+ because the latter does not expect to see any un-filled-in+ coercions, which will happen if we have unsolved equalities.+ By calling reportUnsolvedEqualities first, which fails after+ reporting errors, we avoid that happening.+ See also #18062, #11506 -} -solveLocalEqualitiesX :: String -> TcM a -> TcM (WantedConstraints, a)-solveLocalEqualitiesX callsite thing_inside- = do { traceTc "solveLocalEqualitiesX {" (vcat [ text "Called from" <+> text callsite ]) - ; (result, wanted) <- captureConstraints thing_inside+reportUnsolvedEqualities :: SkolemInfo -> [TcTyVar] -> TcLevel+ -> WantedConstraints -> TcM ()+-- Reports all unsolved wanteds provided; fails in the monad if there are any.+--+-- The provided SkolemInfo and [TcTyVar] arguments are used in an implication to+-- provide skolem info for any errors.+--+reportUnsolvedEqualities skol_info skol_tvs tclvl wanted+ | isEmptyWC wanted+ = return ()+ | otherwise+ = checkNoErrs $ -- Fail+ do { implic <- buildTvImplication skol_info skol_tvs tclvl wanted+ ; reportAllUnsolved (mkImplicWC (unitBag implic)) } - ; traceTc "solveLocalEqualities: running solver" (ppr wanted)- ; residual_wanted <- runTcSEqualities (solveWanteds wanted) - ; traceTc "solveLocalEqualitiesX end }" $- text "residual_wanted =" <+> ppr residual_wanted-- ; return (residual_wanted, result) }---- | Type-check a thing that emits only equality constraints, then--- solve those constraints. Fails outright if there is trouble.--- Use this if you're not going to get another crack at solving--- (because, e.g., you're checking a datatype declaration)-solveEqualities :: TcM a -> TcM a-solveEqualities thing_inside- = checkNoErrs $ -- See Note [Fail fast on kind errors]- do { lvl <- TcM.getTcLevel- ; traceTc "solveEqualities {" (text "level =" <+> ppr lvl)-- ; (result, wanted) <- captureConstraints thing_inside-- ; traceTc "solveEqualities: running solver" $ text "wanted = " <+> ppr wanted- ; final_wc <- runTcSEqualities $ simpl_top wanted- -- NB: Use simpl_top here so that we potentially default RuntimeRep- -- vars to LiftedRep. This is needed to avoid #14991.-- ; traceTc "End solveEqualities }" empty- ; reportAllUnsolved final_wc- ; return result }- -- | Simplify top-level constraints, but without reporting any unsolved -- constraints nor unsafe overlapping.-simpl_top :: WantedConstraints -> TcS WantedConstraints+simplifyTopWanteds :: WantedConstraints -> TcS WantedConstraints -- See Note [Top-level Defaulting Plan]-simpl_top wanteds+simplifyTopWanteds wanteds = do { wc_first_go <- nestTcS (solveWantedsAndDrop wanteds) -- This is where the main work happens ; dflags <- getDynFlags@@ -424,29 +472,8 @@ = return (Just ct) -{- Note [Fail fast on kind errors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-solveEqualities is used to solve kind equalities when kind-checking-user-written types. If solving fails we should fail outright, rather-than just accumulate an error message, for two reasons:-- * A kind-bogus type signature may cause a cascade of knock-on- errors if we let it pass-- * More seriously, we don't have a convenient term-level place to add- deferred bindings for unsolved kind-equality constraints, so we- don't build evidence bindings (by usine reportAllUnsolved). That- means that we'll be left with a type that has coercion holes- in it, something like- <type> |> co-hole- where co-hole is not filled in. Eeek! That un-filled-in- hole actually causes GHC to crash with "fvProv falls into a hole"- See #11563, #11520, #11516, #11399--So it's important to use 'checkNoErrs' here!--Note [When to do type-class defaulting]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{- Note [When to do type-class defaulting]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In GHC 7.6 and 7.8.2, we did type-class defaulting only if insolubleWC was false, on the grounds that defaulting can't help solve insoluble constraints. But if we *don't* do defaulting we may report a whole@@ -592,7 +619,7 @@ `InertCans`. 4) `GHC.Tc.Solver.simplifyTop`:- * Call simpl_top, the top-level function for driving the simplifier for+ * Call simplifyTopWanteds, the top-level function for driving the simplifier for constraint resolution. * Once finished, call `getSafeOverlapFailures` to retrieve the@@ -629,7 +656,7 @@ Note [No defaulting in the ambiguity check] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When simplifying constraints for the ambiguity check, we use-solveWantedsAndDrop, not simpl_top, so that we do no defaulting.+solveWantedsAndDrop, not simplifyTopWanteds, so that we do no defaulting. #11947 was an example: f :: Num a => Int -> Int This is ambiguous of course, but we don't want to default the@@ -718,22 +745,22 @@ ; return () } -------------------tcCheckSatisfiability :: Bag EvVar -> TcM Bool--- Return True if satisfiable, False if definitely contradictory-tcCheckSatisfiability given_ids- = do { lcl_env <- TcM.getLclEnv- ; let given_loc = mkGivenLoc topTcLevel UnkSkol lcl_env- ; (res, _ev_binds) <- runTcS $- do { traceTcS "checkSatisfiability {" (ppr given_ids)- ; let given_cts = mkGivens given_loc (bagToList given_ids)- -- See Note [Superclasses and satisfiability]- ; solveSimpleGivens given_cts- ; insols <- getInertInsols- ; insols <- try_harder insols- ; traceTcS "checkSatisfiability }" (ppr insols)- ; return (isEmptyBag insols) }- ; return res }- where+tcCheckSatisfiability :: InertSet -> Bag EvVar -> TcM (Maybe InertSet)+-- Return (Just new_inerts) if satisfiable, Nothing if definitely contradictory+tcCheckSatisfiability inerts given_ids = do+ (sat, new_inerts) <- runTcSInerts inerts $ do+ traceTcS "checkSatisfiability {" (ppr inerts <+> ppr given_ids)+ lcl_env <- TcS.getLclEnv+ let given_loc = mkGivenLoc topTcLevel UnkSkol lcl_env+ let given_cts = mkGivens given_loc (bagToList given_ids)+ -- See Note [Superclasses and satisfiability]+ solveSimpleGivens given_cts+ insols <- getInertInsols+ insols <- try_harder insols+ traceTcS "checkSatisfiability }" (ppr insols)+ return (isEmptyBag insols)+ return $ if sat then Just new_inerts else Nothing+ where try_harder :: Cts -> TcS Cts -- Maybe we have to search up the superclass chain to find -- an unsatisfiable constraint. Example: pmcheck/T3927b.@@ -749,15 +776,11 @@ -- | Normalise a type as much as possible using the given constraints. -- See @Note [tcNormalise]@.-tcNormalise :: Bag EvVar -> Type -> TcM Type-tcNormalise given_ids ty- = do { lcl_env <- TcM.getLclEnv- ; let given_loc = mkGivenLoc topTcLevel UnkSkol lcl_env- ; norm_loc <- getCtLocM PatCheckOrigin Nothing- ; (res, _ev_binds) <- runTcS $- do { traceTcS "tcNormalise {" (ppr given_ids)- ; let given_cts = mkGivens given_loc (bagToList given_ids)- ; solveSimpleGivens given_cts+tcNormalise :: InertSet -> Type -> TcM Type+tcNormalise inerts ty+ = do { norm_loc <- getCtLocM PatCheckOrigin Nothing+ ; (res, _new_inerts) <- runTcSInerts inerts $+ do { traceTcS "tcNormalise {" (ppr inerts) ; ty' <- flattenType norm_loc ty ; traceTcS "tcNormalise }" (ppr ty') ; pure ty' }@@ -788,19 +811,20 @@ tcNormalise is a rather atypical entrypoint to the constraint solver. Whereas most invocations of the constraint solver are intended to simplify a set of constraints or to decide if a particular set of constraints is satisfiable,-the purpose of tcNormalise is to take a type, plus some local constraints, and-normalise the type as much as possible with respect to those constraints.+the purpose of tcNormalise is to take a type, plus some locally solved+constraints in the form of an InertSet, and normalise the type as much as+possible with respect to those constraints. It does *not* reduce type or data family applications or look through newtypes. Why is this useful? As one example, when coverage-checking an EmptyCase expression, it's possible that the type of the scrutinee will only reduce if some local equalities are solved for. See "Wrinkle: Local equalities"-in Note [Type normalisation] in "GHC.HsToCore.PmCheck".+in Note [Type normalisation] in "GHC.HsToCore.Pmc". -To accomplish its stated goal, tcNormalise first feeds the local constraints-into solveSimpleGivens, then uses flattenType to simplify the desired type-with respect to the givens.+To accomplish its stated goal, tcNormalise first initialises the solver monad+with the given InertCans, then uses flattenType to simplify the desired type+with respect to the Givens in the InertCans. *********************************************************************************** * *@@ -893,7 +917,7 @@ ; psig_theta_vars <- mapM TcM.newEvVar psig_theta ; wanted_transformed_incl_derivs <- setTcLevel rhs_tclvl $- runTcSWithEvBinds ev_binds_var $+ runTcSWithEvBinds ev_binds_var True $ do { let loc = mkGivenLoc rhs_tclvl UnkSkol $ env_lcl tc_env psig_givens = mkGivens loc psig_theta_vars@@ -973,7 +997,7 @@ ; let (outer_simple, inner_simple) = partitionBag is_mono wanted_simple is_mono ct = isWantedCt ct && ctEvId ct `elemVarSet` co_vars - ; _ <- promoteTyVarSet (tyCoVarsOfCts outer_simple)+ ; _ <- TcM.promoteTyVarSet (tyCoVarsOfCts outer_simple) ; let inner_wanted = wanteds { wc_simple = inner_simple } ; implics <- if isEmptyWC inner_wanted@@ -1377,7 +1401,7 @@ | otherwise = transCloVarSet mk_next seed_tcvs where seed_tcvs = tcvs `unionVarSet` tyCoVarsOfTypes ips- (ips, non_ips) = partition isIPPred theta+ (ips, non_ips) = partition isIPLikePred theta -- See Note [Inheriting implicit parameters] in GHC.Tc.Utils.TcType mk_next :: VarSet -> VarSet -- Maps current set to newly-grown ones@@ -2176,29 +2200,6 @@ we'll get more Givens (a unification is like adding a Given) to allow the implication to make progress. -}--promoteTyVar :: TcTyVar -> TcM Bool--- When we float a constraint out of an implication we must restore--- invariant (WantedInv) in Note [TcLevel and untouchable type variables] in GHC.Tc.Utils.TcType--- Return True <=> we did some promotion--- Also returns either the original tyvar (no promotion) or the new one--- See Note [Promoting unification variables]-promoteTyVar tv- = do { tclvl <- TcM.getTcLevel- ; if (isFloatedTouchableMetaTyVar tclvl tv)- then do { cloned_tv <- TcM.cloneMetaTyVar tv- ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl- ; TcM.writeMetaTyVar tv (mkTyVarTy rhs_tv)- ; return True }- else return False }---- Returns whether or not *any* tyvar is defaulted-promoteTyVarSet :: TcTyVarSet -> TcM Bool-promoteTyVarSet tvs- = do { bools <- mapM promoteTyVar (nonDetEltsUniqSet tvs)- -- Non-determinism is OK because order of promotion doesn't matter-- ; return (or bools) } promoteTyVarTcS :: TcTyVar -> TcS () -- When we float a constraint out of an implication we must restore
compiler/GHC/Tc/Solver/Canonical.hs view
@@ -29,7 +29,7 @@ import GHC.Core.TyCo.Rep -- cleverly decomposes types, good for completeness checking import GHC.Core.Coercion import GHC.Core-import GHC.Types.Id( idType, mkTemplateLocals )+import GHC.Types.Id( mkTemplateLocals ) import GHC.Core.FamInstEnv ( FamInstEnvs ) import GHC.Tc.Instance.Family ( tcTopNormaliseNewTypeTF_maybe ) import GHC.Types.Var@@ -96,8 +96,8 @@ canEqNC ev eq_rel ty1 ty2 IrredPred {} -> do traceTcS "canEvNC:irred" (ppr pred) canIrred OtherCIS ev- ForAllPred tvs theta p -> do traceTcS "canEvNC:forall" (ppr pred)- canForAllNC ev tvs theta p+ ForAllPred tvs th p -> do traceTcS "canEvNC:forall" (ppr pred)+ canForAllNC ev tvs th p where pred = ctEvPred ev @@ -542,7 +542,7 @@ mk_given_desc sel_id sc_pred ; mk_superclasses rec_clss given_ev tvs theta sc_pred } where- sc_pred = funResultTy (piResultTys (idType sel_id) tys)+ sc_pred = classMethodInstTy sel_id tys -- See Note [Nested quantified constraint superclasses] mk_given_desc :: Id -> PredType -> (PredType, EvTerm)@@ -708,11 +708,16 @@ ; traceTcS "can_pred" (text "IrredPred = " <+> ppr pred) ; (xi,co) <- flatten FM_FlattenAll ev pred -- co :: xi ~ pred ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev ->+ do { -- Re-classify, in case flattening has improved its shape+ -- Code is like the CNonCanonical case of canonicalize, except+ -- that the IrredPred branch stops work ; case classifyPredType (ctEvPred new_ev) of ClassPred cls tys -> canClassNC new_ev cls tys EqPred eq_rel ty1 ty2 -> canEqNC new_ev eq_rel ty1 ty2- _ -> continueWith $+ ForAllPred tvs th p -> do traceTcS "canEvNC:forall" (ppr pred)+ canForAllNC ev tvs th p+ IrredPred {} -> continueWith $ mkIrredCt status new_ev } } {- *********************************************************************@@ -2106,6 +2111,10 @@ ; continueWith (mkIrredCt status new_ev) } where mtvu = metaTyVarUpdateOK dflags tv1 rhs+ -- Despite the name of the function, tv1 may not be a+ -- unification variable; we are really checking that this+ -- equality is ok to be used to rewrite others, i.e. that+ -- it satisfies the conditions for CTyEqCan role = eqRelRole eq_rel @@ -2135,7 +2144,7 @@ [X] (tv :: k1) ~ (rhs :: k2) -we go to+(where [X] is [G], [W], or [D]), we go to [noDerived X] co :: k2 ~ k1 [X] (tv :: k1) ~ ((rhs |> co) :: k1)@@ -2145,6 +2154,9 @@ noDerived G = G noDerived _ = W +For Wanted/Derived, the [X] constraint is "blocked" (not CTyEqCan, is CIrred)+until the k1~k2 constraint solved: Wrinkle (2).+ Wrinkles: (1) The noDerived step is because Derived equalities have no evidence.@@ -2157,7 +2169,7 @@ [W] (tv :: k1) ~ ((rhs |> co) :: k1) as canonical in the inert set. In particular, we must not unify tv. If we did, the Wanted becomes a Given (effectively), and then can- rewrite other Wanteds. But that's bad: See Note [Wanteds to not rewrite Wanteds]+ rewrite other Wanteds. But that's bad: See Note [Wanteds do not rewrite Wanteds] in GHC.Tc.Types.Constraint. The problem is about poor error messages. See #11198 for tales of destruction.
compiler/GHC/Tc/Solver/Interact.hs view
@@ -566,10 +566,10 @@ ev_id_w = ctEvEvId ev_w different_level_strategy -- Both Given- | isIPPred pred = if lvl_w > lvl_i then KeepWork else KeepInert- | otherwise = if lvl_w > lvl_i then KeepInert else KeepWork+ | 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)- -- For the isIPPred case see Note [Shadowing of Implicit Parameters]+ -- For the isIPLikePred case see Note [Shadowing of Implicit Parameters] same_level_strategy binds -- Both Given | GivenOrigin (InstSC s_i) <- ctLocOrigin loc_i@@ -1071,6 +1071,8 @@ -- programs should typecheck regardless of whether we take this step or -- not. See Note [Shortcut solving] + && not (isIPLikePred (ctEvPred ev_w)) -- Not for implicit parameters (#18627)+ && not (xopt LangExt.IncoherentInstances dflags) -- If IncoherentInstances is on then we cannot rely on coherence of proofs -- in order to justify this optimization: The proof provided by the@@ -1079,6 +1081,7 @@ && gopt Opt_SolveConstantDicts dflags -- Enabled by the -fsolve-constant-dicts flag+ = do { ev_binds_var <- getTcEvBindsVar ; ev_binds <- ASSERT2( not (isCoEvBindsVar ev_binds_var ), ppr ev_w ) getTcEvBindsMap ev_binds_var
compiler/GHC/Tc/Solver/Monad.hs view
@@ -15,7 +15,7 @@ getWorkList, updWorkListTcS, pushLevelNoWorkList, -- The TcS monad- TcS, runTcS, runTcSDeriveds, runTcSWithEvBinds,+ TcS, runTcS, runTcSDeriveds, runTcSWithEvBinds, runTcSInerts, failTcS, warnTcS, addErrTcS, runTcSEqualities, nestTcS, nestImplicTcS, setEvBindsTcS,@@ -55,7 +55,7 @@ tcLookupClass, tcLookupId, -- Inerts- InertSet(..), InertCans(..),+ InertSet(..), InertCans(..), emptyInert, updInertTcS, updInertCans, updInertDicts, updInertIrreds, getNoGivenEqs, setInertCans, getInertEqs, getInertCans, getInertGivens,@@ -2357,10 +2357,8 @@ lookup_flats flat_cache]) } where lookup_inerts inert_funeqs- | Just (CFunEqCan { cc_ev = ctev, cc_fsk = fsk, cc_tyargs = xis })+ | Just (CFunEqCan { cc_ev = ctev, cc_fsk = fsk }) <- findFunEq inert_funeqs fam_tc tys- , tys `eqTypes` xis -- The lookup might find a near-match; see- -- Note [Use loose types in inert set] = Just (ctEvCoercion ctev, mkTyVarTy fsk, ctEvFlavour ctev) | otherwise = Nothing @@ -2377,16 +2375,14 @@ | otherwise -- NB: No caching for equalities, IPs, holes, or errors = return Nothing --- | Look up a dictionary inert. NB: the returned 'CtEvidence' might not--- match the input exactly. Note [Use loose types in inert set].+-- | Look up a dictionary inert. lookupInertDict :: InertCans -> CtLoc -> Class -> [Type] -> Maybe CtEvidence lookupInertDict (IC { inert_dicts = dicts }) loc cls tys = case findDict dicts loc cls tys of Just ct -> Just (ctEvidence ct) _ -> Nothing --- | Look up a solved inert. NB: the returned 'CtEvidence' might not--- match the input exactly. See Note [Use loose types in inert set].+-- | Look up a solved inert. lookupSolvedDict :: InertSet -> CtLoc -> Class -> [Type] -> Maybe CtEvidence -- Returns just if exactly this predicate type exists in the solved. lookupSolvedDict (IS { inert_solved_dicts = solved }) loc cls tys@@ -2412,13 +2408,25 @@ Note [Use loose types in inert set] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Say we know (Eq (a |> c1)) and we need (Eq (a |> c2)). One is clearly-solvable from the other. So, we do lookup in the inert set using-loose types, which omit the kind-check.+Whenever we are looking up an inert dictionary (CDictCan) or function+equality (CFunEqCan), we use a TcAppMap, which uses the Unique of the+class/type family tycon and then a trie which maps the arguments. This+trie does *not* need to match the kinds of the arguments; this Note+explains why. -We must be careful when using the result of a lookup because it may-not match the requested info exactly!+Consider the types ty0 = (T ty1 ty2 ty3 ty4) and ty0' = (T ty1' ty2' ty3' ty4'),+where ty4 and ty4' have different kinds. Let's further assume that both types+ty0 and ty0' are well-typed. Because the kind of T is closed, it must be that+one of the ty1..ty3 does not match ty1'..ty3' (and that the kind of the fourth+argument to T is dependent on whichever one changed). Since we are matching+all arguments, during the inert-set lookup, we know that ty1..ty3 do indeed+match ty1'..ty3'. Therefore, the kind of ty4 and ty4' must match, too --+without ever looking at it. +Accordingly, we use LooseTypeMap, which skips the kind check when looking+up a type. I (Richard E) believe this is just an optimization, and that+looking at kinds would be harmless.+ -} type TcAppMap a = UniqDFM Unique (ListMap LooseTypeMap a)@@ -2527,8 +2535,7 @@ findDict :: DictMap a -> CtLoc -> Class -> [Type] -> Maybe a findDict m loc cls tys- | isCTupleClass cls- , any hasIPPred tys -- See Note [Tuples hiding implicit parameters]+ | hasIPSuperClasses cls tys -- See Note [Tuples hiding implicit parameters] = Nothing | Just {} <- isCallStackPred cls tys@@ -2785,28 +2792,41 @@ -> TcM (a, EvBindMap) runTcS tcs = do { ev_binds_var <- TcM.newTcEvBinds- ; res <- runTcSWithEvBinds ev_binds_var tcs+ ; res <- runTcSWithEvBinds ev_binds_var True tcs ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var ; return (res, ev_binds) }- -- | This variant of 'runTcS' will keep solving, even when only Deriveds -- are left around. It also doesn't return any evidence, as callers won't -- need it. runTcSDeriveds :: TcS a -> TcM a runTcSDeriveds tcs = do { ev_binds_var <- TcM.newTcEvBinds- ; runTcSWithEvBinds ev_binds_var tcs }+ ; runTcSWithEvBinds ev_binds_var True tcs } -- | This can deal only with equality constraints. runTcSEqualities :: TcS a -> TcM a runTcSEqualities thing_inside = do { ev_binds_var <- TcM.newNoTcEvBinds- ; runTcSWithEvBinds ev_binds_var thing_inside }+ ; runTcSWithEvBinds ev_binds_var True thing_inside } +-- | A variant of 'runTcS' that takes and returns an 'InertSet' for+-- later resumption of the 'TcS' session. Crucially, it doesn't+-- 'unflattenGivens' when done.+runTcSInerts :: InertSet -> TcS a -> TcM (a, InertSet)+runTcSInerts inerts tcs = do+ ev_binds_var <- TcM.newTcEvBinds+ -- Passing False here to prohibit unflattening+ runTcSWithEvBinds ev_binds_var False $ do+ setTcSInerts inerts+ a <- tcs+ new_inerts <- getTcSInerts+ return (a, new_inerts)+ runTcSWithEvBinds :: EvBindsVar+ -> Bool -- ^ Unflatten types afterwards? Don't if you want to reuse the InertSet. -> TcS a -> TcM a-runTcSWithEvBinds ev_binds_var tcs+runTcSWithEvBinds ev_binds_var unflatten tcs = do { unified_var <- TcM.newTcRef 0 ; step_count <- TcM.newTcRef 0 ; inert_var <- TcM.newTcRef emptyInert@@ -2824,7 +2844,7 @@ ; when (count > 0) $ csTraceTcM $ return (text "Constraint solver steps =" <+> int count) - ; unflattenGivens inert_var+ ; when unflatten $ unflattenGivens inert_var #if defined(DEBUG) ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var
compiler/GHC/Tc/TyCl.hs view
@@ -30,6 +30,8 @@ import GHC.Hs import GHC.Driver.Types import GHC.Tc.TyCl.Build+import GHC.Tc.Solver( pushLevelAndSolveEqualities, pushLevelAndSolveEqualitiesX+ , reportUnsolvedEqualities ) import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env import GHC.Tc.Validity@@ -38,7 +40,6 @@ import GHC.Tc.TyCl.Class import {-# SOURCE #-} GHC.Tc.TyCl.Instance( tcInstDecls1 ) import GHC.Tc.Deriv (DerivInfo(..))-import GHC.Tc.Utils.Unify ( checkTvConstraints ) import GHC.Tc.Gen.HsType import GHC.Tc.Instance.Class( AssocInstInfo(..) ) import GHC.Tc.Utils.TcMType@@ -52,7 +53,7 @@ import GHC.Tc.Types.Origin import GHC.Core.Type import GHC.Core.TyCo.Rep -- for checkValidRoles-import GHC.Core.TyCo.Ppr( pprTyVars, pprWithExplicitKindsWhen )+import GHC.Core.TyCo.Ppr( pprTyVars ) import GHC.Core.Class import GHC.Core.Coercion.Axiom import GHC.Core.TyCon@@ -61,6 +62,7 @@ import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Var.Set+import GHC.Data.FastString import GHC.Unit import GHC.Types.Name import GHC.Types.Name.Set@@ -78,11 +80,9 @@ import qualified GHC.LanguageExtensions as LangExt import Control.Monad-import Data.Foldable import Data.Function ( on ) import Data.Functor.Identity import Data.List-import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.Set as Set import Data.Tuple( swap )@@ -645,13 +645,18 @@ | otherwise = Left d - ; checked_tcs <- checkInitialKinds kinded_decls+ ; checked_tcs <- checkNoErrs $+ checkInitialKinds kinded_decls+ -- checkNoErrs because we are about to extend+ -- the envt with these tycons, and we get+ -- knock-on errors if we have tycons with+ -- malformed kinds+ ; inferred_tcs- <- tcExtendKindEnvWithTyCons checked_tcs $- pushTcLevelM_ $ -- We are going to kind-generalise, so- -- unification variables in here must- -- be one level in- solveEqualities $+ <- tcExtendKindEnvWithTyCons checked_tcs $+ pushLevelAndSolveEqualities UnkSkol [] $+ -- We are going to kind-generalise, so unification+ -- variables in here must be one level in do { -- Step 1: Bind kind variables for all decls mono_tcs <- inferInitialKinds kindless_decls @@ -1564,7 +1569,9 @@ kcConArgTys :: NewOrData -> Kind -> [HsScaled GhcRn (LHsType GhcRn)] -> TcM () kcConArgTys new_or_data res_kind arg_tys = do { let exp_kind = getArgExpKind new_or_data res_kind- ; mapM_ (flip tcCheckLHsType exp_kind . getBangType . hsScaledThing) arg_tys+ ; forM_ arg_tys (\(HsScaled mult ty) -> do _ <- tcCheckLHsType (getBangType ty) exp_kind+ tcMult mult)+ -- See Note [Implementation of UnliftedNewtypes], STEP 2 } @@ -2301,10 +2308,8 @@ roles = roles_info tycon_name -- for TyCon and Class ; (ctxt, fds, sig_stuff, at_stuff)- <- pushTcLevelM_ $- solveEqualities $- checkTvConstraints skol_info (binderVars binders) $- -- The checkTvConstraints is needed bring into scope the+ <- pushLevelAndSolveEqualities skol_info (binderVars binders) $+ -- The (binderVars binders) is needed bring into scope the -- skolems bound by the class decl header (#17841) do { ctxt <- tcHsContext hs_ctxt ; fds <- mapM (addLocM tc_fundep) fundeps@@ -2312,7 +2317,8 @@ ; at_stuff <- tcClassATs class_name clas ats at_defs ; return (ctxt, fds, sig_stuff, at_stuff) } - -- The solveEqualities will report errors for any++ -- The pushLevelAndSolveEqualities will report errors for any -- unsolved equalities, so these zonks should not encounter -- any unfilled coercion variables unless there is such an error -- The zonk also squeeze out the TcTyCons, and converts@@ -2392,9 +2398,9 @@ ------------------------- tcDefaultAssocDecl ::- TyCon -- ^ Family TyCon (not knot-tied)- -> [LTyFamDefltDecl GhcRn] -- ^ Defaults- -> TcM (Maybe (KnotTied Type, SrcSpan)) -- ^ Type checked RHS+ TyCon -- ^ Family TyCon (not knot-tied)+ -> [LTyFamDefltDecl GhcRn] -- ^ Defaults+ -> TcM (Maybe (KnotTied Type, ATValidityInfo)) -- ^ Type checked RHS tcDefaultAssocDecl _ [] = return Nothing -- No default declaration @@ -2435,74 +2441,28 @@ imp_vars (mb_expl_bndrs `orElse` []) hs_pats hs_rhs_ty - ; let fam_tvs = tyConTyVars fam_tc- ppr_eqn = ppr_default_eqn pats rhs_ty- pats_vis = tyConArgFlags fam_tc pats+ ; let fam_tvs = tyConTyVars fam_tc ; traceTc "tcDefaultAssocDecl 2" (vcat- [ text "fam_tvs" <+> ppr fam_tvs+ [ text "hs_pats" <+> ppr hs_pats+ , text "hs_rhs_ty" <+> ppr hs_rhs_ty+ , text "fam_tvs" <+> ppr fam_tvs , text "qtvs" <+> ppr qtvs- , text "pats" <+> ppr pats- , text "rhs_ty" <+> ppr rhs_ty+ -- NB: Do *not* print `pats` or rhs_ty here, as they can mention+ -- knot-tied TyCons. See #18648. ])- ; cpt_tvs <- zipWithM (extract_tv ppr_eqn) pats pats_vis- ; check_all_distinct_tvs ppr_eqn $ zip cpt_tvs pats_vis- ; let subst = zipTvSubst cpt_tvs (mkTyVarTys fam_tvs)- ; pure $ Just (substTyUnchecked subst rhs_ty, loc)- -- We also perform other checks for well-formedness and validity- -- later, in checkValidClass+ ; let subst = case traverse getTyVar_maybe pats of+ Just cpt_tvs -> zipTvSubst cpt_tvs (mkTyVarTys fam_tvs)+ Nothing -> emptyTCvSubst+ -- The Nothing case can only be reached in invalid+ -- associated type family defaults. In such cases, we+ -- simply create an empty substitution and let GHC fall+ -- over later, in GHC.Tc.Validity.checkValidAssocTyFamDeflt.+ -- See Note [Type-checking default assoc decls].+ ; pure $ Just (substTyUnchecked subst rhs_ty, ATVI loc pats)+ -- We perform checks for well-formedness and validity later, in+ -- GHC.Tc.Validity.checkValidAssocTyFamDeflt. }- where- -- Checks that a pattern on the LHS of a default is a type- -- variable. If so, return the underlying type variable, and if- -- not, throw an error.- -- See Note [Type-checking default assoc decls]- extract_tv :: SDoc -- The pretty-printed default equation- -- (only used for error message purposes)- -> Type -- The particular type pattern from which to extract- -- its underlying type variable- -> ArgFlag -- The visibility of the type pattern- -- (only used for error message purposes)- -> TcM TyVar- extract_tv ppr_eqn pat pat_vis =- case getTyVar_maybe pat of- Just tv -> pure tv- Nothing -> failWithTc $- pprWithExplicitKindsWhen (isInvisibleArgFlag pat_vis) $- hang (text "Illegal argument" <+> quotes (ppr pat) <+> text "in:")- 2 (vcat [ppr_eqn, suggestion]) -- -- Checks that no type variables in an associated default declaration are- -- duplicated. If that is the case, throw an error.- -- See Note [Type-checking default assoc decls]- check_all_distinct_tvs ::- SDoc -- The pretty-printed default equation (only used- -- for error message purposes)- -> [(TyVar, ArgFlag)] -- The type variable arguments in the associated- -- default declaration, along with their respective- -- visibilities (the latter are only used for error- -- message purposes)- -> TcM ()- check_all_distinct_tvs ppr_eqn cpt_tvs_vis =- let dups = findDupsEq ((==) `on` fst) cpt_tvs_vis in- traverse_- (\d -> let (pat_tv, pat_vis) = NE.head d in failWithTc $- pprWithExplicitKindsWhen (isInvisibleArgFlag pat_vis) $- hang (text "Illegal duplicate variable"- <+> quotes (ppr pat_tv) <+> text "in:")- 2 (vcat [ppr_eqn, suggestion]))- dups-- ppr_default_eqn :: [Type] -> Type -> SDoc- ppr_default_eqn pats rhs_ty =- quotes (text "type" <+> ppr (mkTyConApp fam_tc pats)- <+> equals <+> ppr rhs_ty)-- suggestion :: SDoc- suggestion = text "The arguments to" <+> quotes (ppr fam_tc)- <+> text "must all be distinct type variables"-- {- Note [Type-checking default assoc decls] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this default declaration for an associated type@@ -2512,24 +2472,29 @@ type F (x :: j) y = Proxy x -> y Note that the class variable 'a' doesn't scope over the default assoc-decl (rather oddly I think), and (less oddly) neither does the second-argument 'b' of the associated type 'F', or the kind variable 'k'.-Instead, the default decl is treated more like a top-level type-instance.--However we store the default rhs (Proxy x -> y) in F's TyCon, using-F's own type variables, so we need to convert it to (Proxy a -> b).-We do this by creating a substitution [j |-> k, x |-> a, b |-> y] and-applying this substitution to the RHS.+decl, nor do the type variables `k` and `b`. Instead, the default decl is+treated more like a top-level type instance. However, we store the default rhs+(Proxy x -> y) in F's TyCon, using F's own type variables, so we need to+convert it to (Proxy a -> b). We do this in the tcDefaultAssocDecl function by+creating a substitution [j |-> k, x |-> a, b |-> y] and applying this+substitution to the RHS. In order to create this substitution, we must first ensure that all of the arguments in the default instance consist of distinct type variables.-One might think that this is a simple task that could be implemented earlier-in the compiler, perhaps in the parser or the renamer. However, there are some-tricky corner cases that really do require the full power of typechecking to-weed out, as the examples below should illustrate.+Checking for this property proves surprisingly tricky. Three potential places+where GHC could check for this property include: -First, we must check that all arguments are type variables. As a motivating+1. Before typechecking (in the parser or renamer)+2. During typechecking (in tcDefaultAssocDecl)+3. After typechecking (using GHC.Tc.Validity)++Currently, GHC picks option (3) and implements this check using+GHC.Tc.Validity.checkValidAssocTyFamDeflt. GHC previously used options (1) and+(2), but neither option quite worked out for reasons that we will explain+shortly.++The first thing that checkValidAssocTyFamDeflt does is check that all arguments+in an associated type family default are type variables. As a motivating example, consider this erroneous program (inspired by #11361): class C a where@@ -2537,10 +2502,13 @@ type F x b = x If you squint, you'll notice that the kind of `x` is actually Type. However,-we cannot substitute from [Type |-> k], so we reject this default.+we cannot substitute from [Type |-> k], so we reject this default. This also+explains why GHC no longer implements option (1) above, since figuring out that+`x`'s kind is Type would be much more difficult without the knowledge that the+typechecker provides. -Next, we must check that all arguments are distinct. Here is another offending-example, this time taken from #13971:+Next, checkValidAssocTyFamDeflt checks that all arguments are distinct. Here is+another offending example, this time taken from #13971: class C2 (a :: j) where type F2 (a :: j) (b :: k)@@ -2554,10 +2522,37 @@ that we have duplicated a use of `z` on the LHS. Therefore, `F2`'s default is also rejected. -Since the LHS of an associated type family default is always just variables,-it won't contain any tycons. Accordingly, the patterns used in the substitution-won't actually be knot-tied, even though we're in the knot. This is too-delicate for my taste, but it works.+There is one more design consideration in play here: what error message should+checkValidAssocTyFamDeflt produce if one of its checks fails? Ideally, it would+be something like this:++ Illegal duplicate variable ‘z’ in:+ ‘type F2 @z @z x y = ...’+ The arguments to ‘F2’ must all be distinct type variables++This requires printing out the arguments to the associated type family. This+can be dangerous, however. Consider this example, adapted from #18648:++ class C3 a where+ type F3 a+ type F3 (F3 a) = a++F3's default is illegal, since its argument is not a bare type variable. But+note that when we typecheck F3's default, the F3 type constructor is knot-tied.+Therefore, if we print the type `F3 a` in an error message, GHC will diverge!+This is the reason why GHC no longer implements option (2) above and instead+waits until /after/ typechecking has finished, at which point the typechecker+knot has been worked out.++As one final point, one might worry that the typechecker knot could cause the+substitution that tcDefaultAssocDecl creates to diverge, but this is not the+case. Since the LHS of a valid associated type family default is always just+variables, it won't contain any tycons. Accordingly, the patterns used in the+substitution won't actually be knot-tied, even though we're in the knot. (This+is too delicate for my taste, but it works.) If we're dealing with /invalid/+default, such as F3's above, then we simply create an empty substitution and+rely on checkValidAssocTyFamDeflt throwing an error message afterwards before+any damage is done. -} {- *********************************************************************@@ -2715,13 +2710,13 @@ = bindTyClTyVars tc_name $ \ _ binders res_kind -> do { env <- getLclEnv ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env))- ; rhs_ty <- pushTcLevelM_ $- solveEqualities $+ ; rhs_ty <- pushLevelAndSolveEqualities skol_info (binderVars binders) $ tcCheckLHsType hs_ty (TheKind res_kind) ; rhs_ty <- zonkTcTypeToType rhs_ty ; let roles = roles_info tc_name- tycon = buildSynTyCon tc_name binders res_kind roles rhs_ty- ; return tycon }+ ; return (buildSynTyCon tc_name binders res_kind roles rhs_ty) }+ where+ skol_info = TyConSkol TypeSynonymFlavour tc_name tcDataDefn :: SDoc -> RolesInfo -> Name -> HsDataDefn GhcRn -> TcM (TyCon, [DerivInfo])@@ -2751,7 +2746,9 @@ ; unless (mk_permissive_kind hsc_src cons) $ checkDataKindSig (DataDeclSort new_or_data) final_res_kind - ; stupid_tc_theta <- pushTcLevelM_ $ solveEqualities $ tcHsContext ctxt+ ; let skol_tvs = binderVars tycon_binders+ ; stupid_tc_theta <- pushLevelAndSolveEqualities skol_info skol_tvs $+ tcHsContext ctxt ; stupid_theta <- zonkTcTypesToTypes stupid_tc_theta ; kind_signatures <- xoptM LangExt.KindSignatures @@ -2787,6 +2784,9 @@ ; traceTc "tcDataDefn" (ppr tc_name $$ ppr tycon_binders $$ ppr extra_bndrs) ; return (tycon, [deriv_info]) } where+ skol_info = TyConSkol flav tc_name+ flav = newOrDataToFlavour new_or_data+ -- Abstract data types in hsig files can have arbitrary kinds, -- because they may be implemented by type synonyms -- (which themselves can have arbitrary kinds, not just *). See #13955.@@ -2924,40 +2924,38 @@ Note [Generalising in tcTyFamInstEqnGuts] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have something like- type instance forall (a::k) b. F t1 t2 = rhs+ type instance forall (a::k) b. F (Proxy t1) _ = rhs Then imp_vars = [k], exp_bndrs = [a::k, b] -We want to quantify over- * k, a, and b (all user-specified)- * and any inferred free kind vars from- - the kinds of k, a, b- - the types t1, t2+We want to quantify over all the free vars of the LHS including+ * any invisible kind variables arising from instantiating tycons,+ such as Proxy+ * wildcards such as '_' above -However, unlike a type signature like- f :: forall (a::k). blah+So, the simple thing is+ - Gather candidates from the LHS+ - Include any user-specified forall'd variables, so that we get an+ error from Validity.checkFamPatBinders if a forall'd variable is+ not bound on the LHS+ - Quantify over them +Note that, unlike a type signature like+ f :: forall (a::k). blah we do /not/ care about the Inferred/Specified designation or order for the final quantified tyvars. Type-family instances are not invoked directly in Haskell source code, so visible type application etc plays no role. -So, the simple thing is- - gather candidates from [k, a, b] and pats- - quantify over them--Hence the slightly mysterious call:- candidateQTyVarsOfTypes (pats ++ mkTyVarTys scoped_tvs)--Simple, neat, but a little non-obvious!+See also Note [Re-quantify type variables in rules] in+GHC.Tc.Gen.Rule, which explains a /very/ similar design when+generalising over the type of a rewrite rule. -See also Note [Re-quantify type variables in rules] in GHC.Tc.Gen.Rule, which explains-a very similar design when generalising over the type of a rewrite rule. -} -------------------------- tcTyFamInstEqnGuts :: TyCon -> AssocInstInfo- -> [Name] -> [LHsTyVarBndr () GhcRn] -- Implicit and explicicit binder+ -> [Name] -> [LHsTyVarBndr () GhcRn] -- Implicit and explicit binder -> HsTyPats GhcRn -- Patterns -> LHsType GhcRn -- RHS -> TcM ([TyVar], [TcType], TcType) -- (tyvars, pats, rhs)@@ -2970,11 +2968,10 @@ -- This code is closely related to the code -- in GHC.Tc.Gen.HsType.kcCheckDeclHeader_cusk- ; (imp_tvs, (exp_tvs, (lhs_ty, rhs_ty)))- <- pushTcLevelM_ $- solveEqualities $- bindImplicitTKBndrs_Q_Skol imp_vars $- bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $+ ; (tclvl, wanted, (imp_tvs, (exp_tvs, (lhs_ty, rhs_ty))))+ <- pushLevelAndSolveEqualitiesX "tcTyFamInstEqnGuts" $+ bindImplicitTKBndrs_Q_Skol imp_vars $+ bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $ do { (lhs_ty, rhs_kind) <- tcFamTyPats fam_tc hs_pats -- Ensure that the instance is consistent with its -- parent class (#16008)@@ -2982,21 +2979,20 @@ ; rhs_ty <- tcCheckLHsType hs_rhs_ty (TheKind rhs_kind) ; return (lhs_ty, rhs_ty) } - -- See Note [Generalising in tcTyFamInstEqnGuts] -- This code (and the stuff immediately above) is very similar -- to that in tcDataFamInstHeader. Maybe we should abstract the -- common code; but for the moment I concluded that it's -- clearer to duplicate it. Still, if you fix a bug here, -- check there too!- ; let scoped_tvs = imp_tvs ++ exp_tvs- ; dvs <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys scoped_tvs)++ -- See Note [Generalising in tcTyFamInstEqnGuts]+ ; dvs <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys (imp_tvs ++ exp_tvs)) ; qtvs <- quantifyTyVars dvs+ ; reportUnsolvedEqualities FamInstSkol qtvs tclvl wanted ; traceTc "tcTyFamInstEqnGuts 2" $ vcat [ ppr fam_tc- , text "scoped_tvs" <+> pprTyVars scoped_tvs , text "lhs_ty" <+> ppr lhs_ty- , text "dvs" <+> ppr dvs , text "qtvs" <+> pprTyVars qtvs ] ; (ze, qtvs) <- zonkTyBndrs qtvs@@ -3179,11 +3175,11 @@ -> TcM [DataCon] tcConDecl rep_tycon tag_map tmpl_bndrs res_kind res_tmpl new_or_data- (ConDeclH98 { con_name = name+ (ConDeclH98 { con_name = lname@(L _ name) , con_ex_tvs = explicit_tkv_nms , con_mb_cxt = hs_ctxt , con_args = hs_args })- = addErrCtxt (dataConCtxtName [name]) $+ = addErrCtxt (dataConCtxtName [lname]) $ do { -- NB: the tyvars from the declaration header are in scope -- Get hold of the existential type variables@@ -3194,62 +3190,63 @@ ; traceTc "tcConDecl 1" (vcat [ ppr name, ppr explicit_tkv_nms ]) - ; (exp_tvbndrs, (ctxt, arg_tys, field_lbls, stricts))- <- pushTcLevelM_ $- solveEqualities $- bindExplicitTKBndrs_Skol explicit_tkv_nms $+ ; (tclvl, wanted, (exp_tvbndrs, (ctxt, arg_tys, field_lbls, stricts)))+ <- pushLevelAndSolveEqualitiesX "tcConDecl:H98" $+ bindExplicitTKBndrs_Skol explicit_tkv_nms $ do { ctxt <- tcHsMbContext hs_ctxt ; let exp_kind = getArgExpKind new_or_data res_kind ; btys <- tcConArgs exp_kind hs_args- ; field_lbls <- lookupConstructorFields (unLoc name)+ ; field_lbls <- lookupConstructorFields name ; let (arg_tys, stricts) = unzip btys ; return (ctxt, arg_tys, field_lbls, stricts) } + ; let tmpl_tvs = binderVars tmpl_bndrs+ ; let fake_ty = mkSpecForAllTys tmpl_tvs $+ mkInvisForAllTys exp_tvbndrs $+ mkPhiTy ctxt $+ mkVisFunTys arg_tys $+ unitTy+ -- That type is a lie, of course. (It shouldn't end in ()!)+ -- And we could construct a proper result type from the info+ -- at hand. But the result would mention only the tmpl_tvs,+ -- and so it just creates more work to do it right. Really,+ -- we're only doing this to find the right kind variables to+ -- quantify over, and this type is fine for that purpose. -- exp_tvs have explicit, user-written binding sites -- the kvs below are those kind variables entirely unmentioned by the user -- and discovered only by generalization - ; kvs <- kindGeneralizeAll (mkSpecForAllTys tmpl_tvs $- mkInvisForAllTys exp_tvbndrs $- mkPhiTy ctxt $- mkVisFunTys arg_tys $- unitTy)- -- That type is a lie, of course. (It shouldn't end in ()!)- -- And we could construct a proper result type from the info- -- at hand. But the result would mention only the tmpl_tvs,- -- and so it just creates more work to do it right. Really,- -- we're only doing this to find the right kind variables to- -- quantify over, and this type is fine for that purpose.+ ; kvs <- kindGeneralizeAll fake_ty + ; let skol_tvs = kvs ++ tmpl_tvs ++ binderVars exp_tvbndrs+ ; reportUnsolvedEqualities skol_info skol_tvs tclvl wanted+ -- Zonk to Types ; (ze, qkvs) <- zonkTyBndrs kvs ; (ze, user_qtvbndrs) <- zonkTyVarBindersX ze exp_tvbndrs- ; let user_qtvs = binderVars user_qtvbndrs ; arg_tys <- zonkScaledTcTypesToTypesX ze arg_tys ; ctxt <- zonkTcTypesToTypesX ze ctxt - ; fam_envs <- tcGetFamInstEnvs- -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here ; traceTc "tcConDecl 2" (ppr name $$ ppr field_lbls) ; let univ_tvbs = tyConInvisTVBinders tmpl_bndrs univ_tvs = binderVars univ_tvbs- ex_tvbs = mkTyVarBinders InferredSpec qkvs ++- user_qtvbndrs- ex_tvs = qkvs ++ user_qtvs+ ex_tvbs = mkTyVarBinders InferredSpec qkvs ++ user_qtvbndrs+ ex_tvs = binderVars ex_tvbs -- For H98 datatypes, the user-written tyvar binders are precisely -- the universals followed by the existentials. -- See Note [DataCon user type variable binders] in GHC.Core.DataCon. user_tvbs = univ_tvbs ++ ex_tvbs- buildOneDataCon (L _ name) = do- { is_infix <- tcConIsInfixH98 name hs_args- ; rep_nm <- newTyConRepName name - ; buildDataCon fam_envs name is_infix rep_nm+ ; traceTc "tcConDecl 2" (ppr name)+ ; is_infix <- tcConIsInfixH98 name hs_args+ ; rep_nm <- newTyConRepName name+ ; fam_envs <- tcGetFamInstEnvs+ ; dc <- buildDataCon fam_envs name is_infix rep_nm stricts Nothing field_lbls univ_tvs ex_tvs user_tvbs [{- no eq_preds -}] ctxt arg_tys@@ -3257,11 +3254,11 @@ -- NB: we put data_tc, the type constructor gotten from the -- constructor type signature into the data constructor; -- that way checkValidDataCon can complain if it's wrong.- }- ; traceTc "tcConDecl 2" (ppr name)- ; mapM buildOneDataCon [name]- } + ; return [dc] }+ where+ skol_info = DataConSkol name+ tcConDecl rep_tycon tag_map tmpl_bndrs _res_kind res_tmpl new_or_data -- NB: don't use res_kind here, as it's ill-scoped. Instead, -- we get the res_kind by typechecking the result type.@@ -3274,12 +3271,10 @@ do { traceTc "tcConDecl 1 gadt" (ppr names) ; let (L _ name : _) = names - ; (imp_tvs, (exp_tvbndrs, (ctxt, arg_tys, res_ty, field_lbls, stricts)))- <- pushTcLevelM_ $ -- We are going to generalise- solveEqualities $ -- We won't get another crack, and we don't- -- want an error cascade- bindImplicitTKBndrs_Skol implicit_tkv_nms $- bindExplicitTKBndrs_Skol explicit_tkv_nms $+ ; (tclvl, wanted, (imp_tvs, (exp_tvbndrs, (ctxt, arg_tys, res_ty, field_lbls, stricts))))+ <- pushLevelAndSolveEqualitiesX "tcConDecl:GADT" $+ bindImplicitTKBndrs_Skol implicit_tkv_nms $+ bindExplicitTKBndrs_Skol explicit_tkv_nms $ do { ctxt <- tcHsMbContext cxt ; (res_ty, res_kind) <- tcInferLHsTypeKind hs_res_ty -- See Note [GADT return kinds]@@ -3293,17 +3288,19 @@ ; return (ctxt, arg_tys, res_ty, field_lbls, stricts) } ; imp_tvs <- zonkAndScopedSort imp_tvs-- ; tkvs <- kindGeneralizeAll (mkSpecForAllTys imp_tvs $- mkInvisForAllTys exp_tvbndrs $- mkPhiTy ctxt $- mkVisFunTys arg_tys $- res_ty)+ ; let con_ty = mkSpecForAllTys imp_tvs $+ mkInvisForAllTys exp_tvbndrs $+ mkPhiTy ctxt $+ mkVisFunTys arg_tys $+ res_ty+ ; kvs <- kindGeneralizeAll con_ty - ; let tvbndrs = (mkTyVarBinders InferredSpec tkvs)- ++ (mkTyVarBinders SpecifiedSpec imp_tvs)+ ; let tvbndrs = mkTyVarBinders InferredSpec kvs+ ++ mkTyVarBinders SpecifiedSpec imp_tvs ++ exp_tvbndrs + ; reportUnsolvedEqualities skol_info (binderVars tvbndrs) tclvl wanted+ -- Zonk to Types ; (ze, tvbndrs) <- zonkTyVarBinders tvbndrs ; arg_tys <- zonkScaledTcTypesToTypesX ze arg_tys@@ -3318,11 +3315,9 @@ arg_tys' = substScaledTys arg_subst arg_tys res_ty' = substTy arg_subst res_ty -- ; fam_envs <- tcGetFamInstEnvs- -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here ; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls)+ ; fam_envs <- tcGetFamInstEnvs ; let buildOneDataCon (L _ name) = do { is_infix <- tcConIsInfixGADT name hs_args@@ -3337,9 +3332,9 @@ -- constructor type signature into the data constructor; -- that way checkValidDataCon can complain if it's wrong. }- ; traceTc "tcConDecl 2" (ppr names)- ; mapM buildOneDataCon names- }+ ; mapM buildOneDataCon names }+ where+ skol_info = DataConSkol (unLoc (head names)) {- Note [GADT return kinds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -3947,7 +3942,7 @@ data_cons = tyConDataCons tc groups = equivClasses cmp_fld (concatMap get_fields data_cons)- cmp_fld (f1,_) (f2,_) = flLabel f1 `compare` flLabel f2+ cmp_fld (f1,_) (f2,_) = flLabel f1 `uniqCompareFS` flLabel f2 get_fields con = dataConFieldLabels con `zip` repeat con -- dataConFieldLabels may return the empty list, which is fine @@ -4292,10 +4287,14 @@ -- since there is no possible ambiguity (#10020) -- Check that any default declarations for associated types are valid- ; whenIsJust m_dflt_rhs $ \ (rhs, loc) ->- setSrcSpan loc $- tcAddFamInstCtxt (text "default type instance") (getName fam_tc) $- checkValidTyFamEqn fam_tc fam_tvs (mkTyVarTys fam_tvs) rhs }+ ; whenIsJust m_dflt_rhs $ \ (rhs, at_validity_info) ->+ case at_validity_info of+ NoATVI -> pure ()+ ATVI loc pats ->+ setSrcSpan loc $+ tcAddFamInstCtxt (text "default type instance") (getName fam_tc) $+ do { checkValidAssocTyFamDeflt fam_tc pats+ ; checkValidTyFamEqn fam_tc fam_tvs (mkTyVarTys fam_tvs) rhs }} where fam_tvs = tyConTyVars fam_tc
compiler/GHC/Tc/TyCl/Instance.hs view
@@ -30,6 +30,7 @@ import GHC.Tc.TyCl.Class ( tcClassDecl2, tcATDefault, HsSigFun, mkHsSigFun, badMethodErr, findMethodBind, instantiateMethod )+import GHC.Tc.Solver( pushLevelAndSolveEqualitiesX, reportUnsolvedEqualities ) import GHC.Tc.Gen.Sig import GHC.Tc.Utils.Monad import GHC.Tc.Validity@@ -51,8 +52,10 @@ import GHC.Tc.Utils.Unify import GHC.Core ( Expr(..), mkApps, mkVarApps, mkLams ) import GHC.Core.Make ( nO_METHOD_BINDING_ERROR_ID )-import GHC.Core.Unfold ( mkInlineUnfoldingWithArity, mkDFunUnfolding )+import GHC.Core.Unfold.Make ( mkInlineUnfoldingWithArity, mkDFunUnfolding ) import GHC.Core.Type+import GHC.Core.SimpleOpt+import GHC.Core.Predicate( classMethodInstTy ) import GHC.Tc.Types.Evidence import GHC.Core.TyCon import GHC.Core.Coercion.Axiom@@ -854,11 +857,10 @@ tcDataFamInstHeader mb_clsinfo fam_tc imp_vars mb_bndrs fixity hs_ctxt hs_pats m_ksig hs_cons new_or_data = do { traceTc "tcDataFamInstHeader {" (ppr fam_tc <+> ppr hs_pats)- ; (imp_tvs, (exp_tvs, (stupid_theta, lhs_ty, master_res_kind, instance_res_kind)))- <- pushTcLevelM_ $- solveEqualities $- bindImplicitTKBndrs_Q_Skol imp_vars $- bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $+ ; (tclvl, wanted, (imp_tvs, (exp_tvs, (stupid_theta, lhs_ty, master_res_kind, instance_res_kind))))+ <- pushLevelAndSolveEqualitiesX "tcDataFamInstHeader" $+ bindImplicitTKBndrs_Q_Skol imp_vars $+ bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $ do { stupid_theta <- tcHsContext hs_ctxt ; (lhs_ty, lhs_kind) <- tcFamTyPats fam_tc hs_pats ; (lhs_applied_ty, lhs_applied_kind)@@ -880,7 +882,7 @@ -- is compatible with the explicit signature (or Type, if there -- is none) ; let hs_lhs = nlHsTyConApp fixity (getName fam_tc) hs_pats- ; _ <- unifyKind (Just (unLoc hs_lhs)) lhs_applied_kind res_kind+ ; _ <- unifyKind (Just (ppr hs_lhs)) lhs_applied_kind res_kind ; traceTc "tcDataFamInstHeader" $ vcat [ ppr fam_tc, ppr m_ksig, ppr lhs_applied_kind, ppr res_kind ]@@ -889,19 +891,20 @@ , lhs_applied_kind , res_kind ) } - -- See GHC.Tc.TyCl Note [Generalising in tcFamTyPatsGuts] -- This code (and the stuff immediately above) is very similar -- to that in tcTyFamInstEqnGuts. Maybe we should abstract the -- common code; but for the moment I concluded that it's -- clearer to duplicate it. Still, if you fix a bug here, -- check there too!- ; let scoped_tvs = imp_tvs ++ exp_tvs- ; dvs <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys scoped_tvs)++ -- See GHC.Tc.TyCl Note [Generalising in tcFamTyPatsGuts]+ ; dvs <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys (imp_tvs ++ exp_tvs)) ; qtvs <- quantifyTyVars dvs+ ; reportUnsolvedEqualities FamInstSkol qtvs tclvl wanted -- Zonk the patterns etc into the Type world ; (ze, qtvs) <- zonkTyBndrs qtvs- ; lhs_ty <- zonkTcTypeToTypeX ze lhs_ty+ ; lhs_ty <- zonkTcTypeToTypeX ze lhs_ty ; stupid_theta <- zonkTcTypesToTypesX ze stupid_theta ; master_res_kind <- zonkTcTypeToTypeX ze master_res_kind ; instance_res_kind <- zonkTcTypeToTypeX ze instance_res_kind@@ -923,9 +926,9 @@ ; return (qtvs, pats, master_res_kind, stupid_theta) } where- fam_name = tyConName fam_tc- data_ctxt = DataKindCtxt fam_name- exp_bndrs = mb_bndrs `orElse` []+ fam_name = tyConName fam_tc+ data_ctxt = DataKindCtxt fam_name+ exp_bndrs = mb_bndrs `orElse` [] -- See Note [Implementation of UnliftedNewtypes] in GHC.Tc.TyCl, wrinkle (2). tc_kind_sig Nothing@@ -1207,7 +1210,7 @@ -- is messing with. addDFunPrags dfun_id sc_meth_ids | is_newtype- = dfun_id `setIdUnfolding` mkInlineUnfoldingWithArity 0 con_app+ = dfun_id `setIdUnfolding` mkInlineUnfoldingWithArity 0 defaultSimpleOpts con_app `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 } | otherwise = dfun_id `setIdUnfolding` mkDFunUnfolding dfun_bndrs dict_con dict_args@@ -1633,7 +1636,7 @@ nO_METHOD_BINDING_ERROR_ID error_msg dflags = L inst_loc (HsLit noExtField (HsStringPrim NoSourceText (unsafeMkByteString (error_string dflags))))- meth_tau = funResultTy (piResultTys (idType sel_id) inst_tys)+ meth_tau = classMethodInstTy sel_id inst_tys error_string dflags = showSDoc dflags (hcat [ppr inst_loc, vbar, ppr sel_id ]) lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars
compiler/GHC/Tc/TyCl/PatSyn.hs view
@@ -15,8 +15,7 @@ module GHC.Tc.TyCl.PatSyn ( tcPatSynDecl , tcPatSynBuilderBind- , tcPatSynBuilderOcc- , nonBidirectionalErr+ , patSynBuilderOcc ) where @@ -884,13 +883,12 @@ add_dummy_arg other_mg = pprPanic "add_dummy_arg" $ pprMatches other_mg -tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr GhcTc, TcSigmaType)--- monadic only for failure-tcPatSynBuilderOcc ps- | Just (builder_id, add_void_arg) <- builder+patSynBuilderOcc :: PatSyn -> Maybe (HsExpr GhcTc, TcSigmaType)+patSynBuilderOcc ps+ | Just (builder_id, add_void_arg) <- patSynBuilder ps , let builder_expr = HsConLikeOut noExtField (PatSynCon ps) builder_ty = idType builder_id- = return $+ = Just $ if add_void_arg then ( builder_expr -- still just return builder_expr; the void# arg is added -- by dsConLike in the desugarer@@ -898,10 +896,7 @@ else (builder_expr, builder_ty) | otherwise -- Unidirectional- = nonBidirectionalErr name- where- name = patSynName ps- builder = patSynBuilder ps+ = Nothing add_void :: Bool -> Type -> Type add_void need_dummy_arg ty@@ -1090,11 +1085,6 @@ want to avoid difficult to decipher core lint errors! -} --nonBidirectionalErr :: Outputable name => name -> TcM a-nonBidirectionalErr name = failWithTc $- text "non-bidirectional pattern synonym"- <+> quotes (ppr name) <+> text "used in an expression" -- Walk the whole pattern and for all ConPatOuts, collect the -- existentially-bound type variables and evidence binding variables.
compiler/GHC/Tc/TyCl/PatSyn.hs-boot view
@@ -3,7 +3,6 @@ import GHC.Hs ( PatSynBind, LHsBinds ) import GHC.Tc.Types ( TcM, TcSigInfo ) import GHC.Tc.Utils.Monad ( TcGblEnv)-import GHC.Utils.Outputable ( Outputable ) import GHC.Hs.Extension ( GhcRn, GhcTc ) import Data.Maybe ( Maybe ) @@ -13,4 +12,3 @@ tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc) -nonBidirectionalErr :: Outputable name => name -> TcM a
compiler/GHC/Tc/TyCl/Utils.hs view
@@ -1095,9 +1095,4 @@ instantiate `a` with `(forall b. b -> b) -> Int`, which is impredicative. To make sure that GHC is OK with this, we enable ImpredicativeTypes interally when typechecking these HsBinds so that the user does not have to.--Although ImpredicativeTypes is somewhat fragile and unpredictable in GHC right-now, it will become robust when Quick Look impredicativity is implemented. In-the meantime, using ImpredicativeTypes to instantiate the `a` type variable in-recSelError's type does actually work, so its use here is benign. -}
compiler/GHC/Tc/Utils/Backpack.hs view
@@ -68,6 +68,7 @@ import GHC.Tc.Utils.Unify import GHC.Iface.Rename import GHC.Utils.Misc+import GHC.Unit.State import Control.Monad import Data.List (find)
compiler/GHC/Tc/Utils/Env.hs view
@@ -64,8 +64,8 @@ topIdLvl, isBrackStage, -- New Ids- newDFunName, newFamInstTyConName,- newFamInstAxiomName,+ newDFunName,+ newFamInstTyConName, newFamInstAxiomName, mkStableIdFromString, mkStableIdFromName, mkWrapperName ) where
compiler/GHC/Tc/Utils/Instantiate.hs view
@@ -12,7 +12,7 @@ module GHC.Tc.Utils.Instantiate ( topSkolemise,- topInstantiate, topInstantiateInferred,+ topInstantiate, instantiateSigma, instCall, instDFunType, instStupidTheta, instTyVarsWith, newWanted, newWanteds, @@ -72,6 +72,7 @@ import GHC.Types.Var import GHC.Core.DataCon import GHC.Types.Var.Env+import GHC.Types.Var.Set import GHC.Builtin.Names import GHC.Types.SrcLoc as SrcLoc import GHC.Driver.Session@@ -189,66 +190,44 @@ -- and e :: ty -- then wrap e :: rho (that is, wrap :: ty "->" rho) -- NB: always returns a rho-type, with no top-level forall or (=>)-topInstantiate = top_instantiate True---- | Instantiate all outer 'Inferred' binders--- and any context. Never looks through arrows or specified type variables.--- Used for visible type application.-topInstantiateInferred :: CtOrigin -> TcSigmaType- -> TcM (HsWrapper, TcSigmaType)--- if topInstantiate ty = (wrap, rho)--- and e :: ty--- then wrap e :: rho--- NB: may return a sigma-type-topInstantiateInferred = top_instantiate False--top_instantiate :: Bool -- True <=> instantiate *all* variables- -- False <=> instantiate only the inferred ones- -> CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)-top_instantiate inst_all orig ty- | (binders, phi) <- tcSplitForAllVarBndrs ty- , (theta, rho) <- tcSplitPhiTy phi- , not (null binders && null theta)- = do { let (inst_bndrs, leave_bndrs) = span should_inst binders- (inst_theta, leave_theta)- | null leave_bndrs = (theta, [])- | otherwise = ([], theta)- in_scope = mkInScopeSet (tyCoVarsOfType ty)- empty_subst = mkEmptyTCvSubst in_scope- inst_tvs = binderVars inst_bndrs- ; (subst, inst_tvs') <- mapAccumLM newMetaTyVarX empty_subst inst_tvs- ; let inst_theta' = substTheta subst inst_theta- sigma' = substTy subst (mkForAllTys leave_bndrs $- mkPhiTy leave_theta rho)- inst_tv_tys' = mkTyVarTys inst_tvs'+topInstantiate orig ty+ | (tvs, theta, body) <- tcSplitSigmaTy ty+ , not (null tvs && null theta)+ = do { (_, wrap1, body1) <- instantiateSigma orig tvs theta body - ; wrap1 <- instCall orig inst_tv_tys' inst_theta'- ; traceTc "Instantiating"- (vcat [ text "all tyvars?" <+> ppr inst_all- , text "origin" <+> pprCtOrigin orig- , text "type" <+> debugPprType ty- , text "theta" <+> ppr theta- , text "leave_bndrs" <+> ppr leave_bndrs- , text "with" <+> vcat (map debugPprType inst_tv_tys')- , text "theta:" <+> ppr inst_theta' ])+ -- Loop, to account for types like+ -- forall a. Num a => forall b. Ord b => ...+ ; (wrap2, rho) <- topInstantiate orig body1 - ; (wrap2, rho2) <-- if null leave_bndrs -- NB: if inst_all is True then leave_bndrs = []+ ; return (wrap2 <.> wrap1, rho) } - -- account for types like forall a. Num a => forall b. Ord b => ...- then top_instantiate inst_all orig sigma'+ | otherwise = return (idHsWrapper, ty) - -- but don't loop if there were any un-inst'able tyvars- else return (idHsWrapper, sigma')+instantiateSigma :: CtOrigin -> [TyVar] -> TcThetaType -> TcSigmaType+ -> TcM ([TcTyVar], HsWrapper, TcSigmaType)+-- (instantiate orig tvs theta ty)+-- instantiates the the type variables tvs, emits the (instantiated)+-- constraints theta, and returns the (instantiated) type ty+instantiateSigma orig tvs theta body_ty+ = do { (subst, inst_tvs) <- mapAccumLM newMetaTyVarX empty_subst tvs+ ; let inst_theta = substTheta subst theta+ inst_body = substTy subst body_ty+ inst_tv_tys = mkTyVarTys inst_tvs - ; return (wrap2 <.> wrap1, rho2) }+ ; wrap <- instCall orig inst_tv_tys inst_theta+ ; traceTc "Instantiating"+ (vcat [ text "origin" <+> pprCtOrigin orig+ , text "tvs" <+> ppr tvs+ , text "theta" <+> ppr theta+ , text "type" <+> debugPprType body_ty+ , text "with" <+> vcat (map debugPprType inst_tv_tys)+ , text "theta:" <+> ppr inst_theta ]) - | otherwise = return (idHsWrapper, ty)+ ; return (inst_tvs, wrap, inst_body) } where-- should_inst bndr- | inst_all = True- | otherwise = binderArgFlag bndr == Inferred+ free_tvs = tyCoVarsOfType body_ty `unionVarSet` tyCoVarsOfTypes theta+ in_scope = mkInScopeSet (free_tvs `delVarSetList` tvs)+ empty_subst = mkEmptyTCvSubst in_scope instTyVarsWith :: CtOrigin -> [TyVar] -> [TcType] -> TcM TCvSubst -- Use this when you want to instantiate (forall a b c. ty) with
compiler/GHC/Tc/Utils/Monad.hs view
@@ -138,7 +138,7 @@ withException, -- * Stuff for cost centres.- ContainsCostCentreState(..), getCCIndexM,+ getCCIndexM, getCCIndexTcM, -- * Types etc. module GHC.Tc.Types,@@ -1816,11 +1816,34 @@ the visible type application fails in the monad (throws an exception). We must not discard the out-of-scope error. -So we /retain the insoluble constraints/ if there is an exception.-Hence:- - insolublesOnly in tryCaptureConstraints- - emitConstraints in the Left case of captureConstraints+It's distressingly delicate though: +* If we discard too /many/ constraints we may fail to report the error+ that led us to interrupte the constraint gathering process.++ One particular example "variable out of scope" Hole constraints. For+ example (#12529):+ f = p @ Int+ Here 'p' is out of scope, so we get an insoluble Hole constraint. But+ the visible type application fails in the monad (throws an exception).+ We must not discard the out-of-scope error.++ Also GHC.Tc.Solver.emitFlatConstraints may fail having emitted some+ constraints with skolem-escape problems.++* If we discard too /few/ constraints, we may get the misleading+ class constraints mentioned above. But we may /also/ end up taking+ constraints built at some inner level, and emitting them at some+ outer level, and then breaking the TcLevel invariants+ See Note [TcLevel and untouchable type variables] in GHC.Tc.Utils.TcType++So dropMisleading has a horridly ad-hoc structure. It keeps only+/insoluble/ flat constraints (which are unlikely to very visibly trip+up on the TcLevel invariant, but all /implication/ constraints (except+the class constraints inside them). The implication constraints are+OK because they set the ambient level before attempting to solve any+inner constraints. Ugh! I hate this. But it seems to work.+ However note that freshly-generated constraints like (Int ~ Bool), or ((a -> b) ~ Int) are all CNonCanonical, and hence won't be flagged as insoluble. The constraint solver does that. So they'll be discarded.@@ -2081,23 +2104,16 @@ we can use uninterruptibleMask_ to avoid the situation. -} --- | Environments which track 'CostCentreState'-class ContainsCostCentreState e where- extractCostCentreState :: e -> TcRef CostCentreState--instance ContainsCostCentreState TcGblEnv where- extractCostCentreState = tcg_cc_st--instance ContainsCostCentreState DsGblEnv where- extractCostCentreState = ds_cc_st- -- | Get the next cost centre index associated with a given name.-getCCIndexM :: (ContainsCostCentreState gbl)- => FastString -> TcRnIf gbl lcl CostCentreIndex-getCCIndexM nm = do+getCCIndexM :: (gbl -> TcRef CostCentreState) -> FastString -> TcRnIf gbl lcl CostCentreIndex+getCCIndexM get_ccs nm = do env <- getGblEnv- let cc_st_ref = extractCostCentreState env+ let cc_st_ref = get_ccs env cc_st <- readTcRef cc_st_ref let (idx, cc_st') = getCCIndex nm cc_st writeTcRef cc_st_ref cc_st' return idx++-- | See 'getCCIndexM'.+getCCIndexTcM :: FastString -> TcM CostCentreIndex+getCCIndexTcM = getCCIndexM tcg_cc_st
compiler/GHC/Tc/Utils/TcMType.hs view
@@ -4,7 +4,7 @@ -} -{-# LANGUAGE CPP, TupleSections, MultiWayIf, PatternSynonyms #-}+{-# LANGUAGE CPP, TupleSections, MultiWayIf, PatternSynonyms, BangPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -21,9 +21,9 @@ newNamedFlexiTyVar, newFlexiTyVarTy, -- Kind -> TcM TcType newFlexiTyVarTys, -- Int -> Kind -> TcM [TcType]- newOpenFlexiTyVarTy, newOpenTypeKind,+ newOpenFlexiTyVar, newOpenFlexiTyVarTy, newOpenTypeKind, newMetaKindVar, newMetaKindVars, newMetaTyVarTyAtLevel,- cloneMetaTyVar,+ newAnonMetaTyVar, cloneMetaTyVar, newFmvTyVar, newFskTyVar, newMultiplicityVar,@@ -70,20 +70,24 @@ zonkTcTyVarToTyVar, zonkInvisTVBinder, zonkTyCoVarsAndFV, zonkTcTypeAndFV, zonkDTyCoVarSetAndFV, zonkTyCoVarsAndFVList,- candidateQTyVarsOfType, candidateQTyVarsOfKind,- candidateQTyVarsOfTypes, candidateQTyVarsOfKinds,- CandidatesQTvs(..), delCandidates, candidateKindVars, partitionCandidates,- zonkAndSkolemise, skolemiseQuantifiedTyVar,- defaultTyVar, quantifyTyVars, isQuantifiableTv,+ zonkTcType, zonkTcTypes, zonkCo, zonkTyCoVarKind, zonkTyCoVarKindBinder,- zonkEvVar, zonkWC, zonkImplication, zonkSimples, zonkId, zonkCoVar, zonkCt, zonkSkolemInfo, - skolemiseUnboundMetaTyVar,+ ---------------------------------+ -- Promotion, defaulting, skolemisation+ defaultTyVar, promoteTyVar, promoteTyVarSet,+ quantifyTyVars, isQuantifiableTv,+ skolemiseUnboundMetaTyVar, zonkAndSkolemise, skolemiseQuantifiedTyVar, + candidateQTyVarsOfType, candidateQTyVarsOfKind,+ candidateQTyVarsOfTypes, candidateQTyVarsOfKinds,+ CandidatesQTvs(..), delCandidates,+ candidateKindVars, partitionCandidates,+ ------------------------------ -- Levity polymorphism ensureNotLevPoly, checkForLevPoly, checkForLevPolyX, formatLevPolyErr@@ -464,7 +468,7 @@ -- | Returns the expected type when in checking mode. checkingExpType_maybe :: ExpType -> Maybe TcType checkingExpType_maybe (Check ty) = Just ty-checkingExpType_maybe _ = Nothing+checkingExpType_maybe (Infer {}) = Nothing -- | Returns the expected type when in checking mode. Panics if in inference -- mode.@@ -759,7 +763,6 @@ {- Note [TyVarTv] ~~~~~~~~~~~~~~~~~- A TyVarTv can unify with type *variables* only, including other TyVarTvs and skolems. Sometimes, they can unify with type variables that the user would rather keep distinct; see #11203 for an example. So, any client of this@@ -774,7 +777,7 @@ The remaining uses of newTyVarTyVars are * In kind signatures, see GHC.Tc.TyCl Note [Inferring kinds for type declarations]- and Note [Kind checking for GADTs]+ and Note [Kind checking for GADTs] * In partial type signatures, see Note [Quantified variables in partial type signatures] -} @@ -801,10 +804,11 @@ metaInfoToTyVarName :: MetaInfo -> FastString metaInfoToTyVarName meta_info = case meta_info of- TauTv -> fsLit "t"- FlatMetaTv -> fsLit "fmv"- FlatSkolTv -> fsLit "fsk"- TyVarTv -> fsLit "a"+ TauTv -> fsLit "t"+ FlatMetaTv -> fsLit "fmv"+ FlatSkolTv -> fsLit "fsk"+ TyVarTv -> fsLit "a"+ RuntimeUnkTv -> fsLit "r" newAnonMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar newAnonMetaTyVar mi = newNamedAnonMetaTyVar (metaInfoToTyVarName mi) mi@@ -1079,8 +1083,13 @@ -- Returns alpha :: TYPE kappa, where both alpha and kappa are fresh newOpenFlexiTyVarTy :: TcM TcType newOpenFlexiTyVarTy+ = do { tv <- newOpenFlexiTyVar+ ; return (mkTyVarTy tv) }++newOpenFlexiTyVar :: TcM TcTyVar+newOpenFlexiTyVar = do { kind <- newOpenTypeKind- ; newFlexiTyVarTy kind }+ ; newFlexiTyVar kind } newMetaTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) -- Instantiate with META type variables@@ -1618,11 +1627,11 @@ generalisation, and so we generalise it. alpha[1] does not, and so we leave it alone. -Note that not *every* variable with a higher level will get generalised,-either due to the monomorphism restriction or other quirks. See, for-example, the code in GHC.Tc.Solver.decideMonoTyVars and in-GHC.Tc.Gen.HsType.kindGeneralizeSome, both of which exclude certain otherwise-eligible-variables from being generalised.+Note that not *every* variable with a higher level will get+generalised, either due to the monomorphism restriction or other+quirks. See, for example, the code in GHC.Tc.Solver.decideMonoTyVars+and in GHC.Tc.Gen.HsType.kindGeneralizeSome, both of which exclude+certain otherwise-eligible variables from being generalised. Using level numbers for quantification is implemented in the candidateQTyVars... functions, by adding only those variables with a level strictly higher than@@ -1642,10 +1651,9 @@ Note [Deterministic UniqFM] in GHC.Types.Unique.DFM. -} -quantifyTyVars- :: CandidatesQTvs -- See Note [Dependent type variables]- -- Already zonked- -> TcM [TcTyVar]+quantifyTyVars :: CandidatesQTvs -- See Note [Dependent type variables]+ -- Already zonked+ -> TcM [TcTyVar] -- See Note [quantifyTyVars] -- Can be given a mixture of TcTyVars and TyVars, in the case of -- associated type declarations. Also accepts covars, but *never* returns any.@@ -1653,28 +1661,28 @@ -- invariants on CandidateQTvs, we do not have to filter out variables -- free in the environment here. Just quantify unconditionally, subject -- to the restrictions in Note [quantifyTyVars].-quantifyTyVars dvs@(DV{ dv_kvs = dep_tkvs, dv_tvs = nondep_tkvs })+quantifyTyVars dvs@(DV{ dv_kvs = dep_kv_set, dv_tvs = nondep_tkv_set }) -- short-circuit common case- | isEmptyDVarSet dep_tkvs- , isEmptyDVarSet nondep_tkvs+ | isEmptyDVarSet dep_kv_set+ , isEmptyDVarSet nondep_tkv_set = do { traceTc "quantifyTyVars has nothing to quantify" empty ; return [] } | otherwise- = do { traceTc "quantifyTyVars 1" (ppr dvs)+ = do { traceTc "quantifyTyVars {" (ppr dvs) - ; let dep_kvs = scopedSort $ dVarSetElems dep_tkvs- -- scopedSort: put the kind variables into- -- well-scoped order.- -- E.g. [k, (a::k)] not the other way round+ ; let dep_kvs = scopedSort $ dVarSetElems dep_kv_set+ -- scopedSort: put the kind variables into+ -- well-scoped order.+ -- E.g. [k, (a::k)] not the other way round - nondep_tvs = dVarSetElems (nondep_tkvs `minusDVarSet` dep_tkvs)+ nondep_tvs = dVarSetElems (nondep_tkv_set `minusDVarSet` dep_kv_set) -- See Note [Dependent type variables] -- The `minus` dep_tkvs removes any kind-level vars -- e.g. T k (a::k) Since k appear in a kind it'll -- be in dv_kvs, and is dependent. So remove it from -- dv_tvs which will also contain k- -- NB kinds of tvs are zonked by zonkTyCoVarsAndFV+ -- NB kinds of tvs are already zonked -- In the non-PolyKinds case, default the kind variables -- to *, and zonk the tyvars as usual. Notice that this@@ -1688,7 +1696,7 @@ -- mentioned in the kinds of the nondep_tvs' -- now refer to the dep_kvs' - ; traceTc "quantifyTyVars 2"+ ; traceTc "quantifyTyVars }" (vcat [ text "nondep:" <+> pprTyVars nondep_tvs , text "dep:" <+> pprTyVars dep_kvs , text "dep_kvs'" <+> pprTyVars dep_kvs'@@ -2017,14 +2025,45 @@ All very silly. I think its harmless to ignore the problem. We'll end up with a \/\a in the final result but all the occurrences of a will be zonked to ()+-} -************************************************************************+{- ********************************************************************* * *- Zonking types+ Promotion * *-************************************************************************+********************************************************************* -} --}+promoteTyVar :: TcTyVar -> TcM Bool+-- When we float a constraint out of an implication we must restore+-- invariant (WantedInv) in Note [TcLevel and untouchable type variables] in GHC.Tc.Utils.TcType+-- Return True <=> we did some promotion+-- Also returns either the original tyvar (no promotion) or the new one+-- See Note [Promoting unification variables]+promoteTyVar tv+ = do { tclvl <- getTcLevel+ ; if (isFloatedTouchableMetaTyVar tclvl tv)+ then do { cloned_tv <- cloneMetaTyVar tv+ ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl+ ; writeMetaTyVar tv (mkTyVarTy rhs_tv)+ ; traceTc "promoteTyVar" (ppr tv <+> text "-->" <+> ppr rhs_tv)+ ; return True }+ else do { traceTc "promoteTyVar: no" (ppr tv)+ ; return False } }++-- Returns whether or not *any* tyvar is defaulted+promoteTyVarSet :: TcTyVarSet -> TcM Bool+promoteTyVarSet tvs+ = do { bools <- mapM promoteTyVar (nonDetEltsUniqSet tvs)+ -- Non-determinism is OK because order of promotion doesn't matter++ ; return (or bools) }+++{- *********************************************************************+* *+ Zonking types+* *+********************************************************************* -} zonkTcTypeAndFV :: TcType -> TcM DTyCoVarSet -- Zonk a type and take its free variables
compiler/GHC/Tc/Utils/Unify.hs view
@@ -32,8 +32,8 @@ matchExpectedTyConApp, matchExpectedAppTy, matchExpectedFunTys,- matchActualFunTysRho, matchActualFunTySigma, matchExpectedFunKind,+ matchActualFunTySigma, matchActualFunTysRho, metaTyVarUpdateOK, occCheckForErrors, MetaTyVarUpdateResult(..) @@ -69,13 +69,155 @@ import GHC.Types.Basic import GHC.Data.Bag import GHC.Utils.Misc-import qualified GHC.LanguageExtensions as LangExt import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import Control.Monad import Control.Arrow ( second ) ++{- *********************************************************************+* *+ matchActualFunTys+* *+********************************************************************* -}++-- | matchActualFunTySigma does looks for just one function arrow+-- returning an uninstantiated sigma-type+matchActualFunTySigma+ :: SDoc -- See Note [Herald for matchExpectedFunTys]+ -> Maybe SDoc -- The thing with type TcSigmaType+ -> (Arity, [Scaled TcSigmaType]) -- Total number of value args in the call, and+ -- types of values args to which function has+ -- been applied already (reversed)+ -- Both are used only for error messages)+ -> TcRhoType -- Type to analyse: a TcRhoType+ -> TcM (HsWrapper, Scaled TcSigmaType, TcSigmaType)+-- The /argument/ is a RhoType+-- The /result/ is an (uninstantiated) SigmaType+--+-- See Note [matchActualFunTy error handling] for the first three arguments++-- If (wrap, arg_ty, res_ty) = matchActualFunTySigma ... fun_ty+-- then wrap :: fun_ty ~> (arg_ty -> res_ty)+-- and NB: res_ty is an (uninstantiated) SigmaType++matchActualFunTySigma herald mb_thing err_info fun_ty+ = ASSERT2( isRhoTy fun_ty, ppr fun_ty )+ go fun_ty+ where+ -- Does not allocate unnecessary meta variables: if the input already is+ -- a function, we just take it apart. Not only is this efficient,+ -- it's important for higher rank: the argument might be of form+ -- (forall a. ty) -> other+ -- If allocated (fresh-meta-var1 -> fresh-meta-var2) and unified, we'd+ -- hide the forall inside a meta-variable+ go :: TcRhoType -- The type we're processing, perhaps after+ -- expanding any type synonym+ -> TcM (HsWrapper, Scaled TcSigmaType, TcSigmaType)+ go ty | Just ty' <- tcView ty = go ty'++ go (FunTy { ft_af = af, ft_mult = w, ft_arg = arg_ty, ft_res = res_ty })+ = ASSERT( af == VisArg )+ return (idHsWrapper, Scaled w arg_ty, res_ty)++ go ty@(TyVarTy tv)+ | isMetaTyVar tv+ = do { cts <- readMetaTyVar tv+ ; case cts of+ Indirect ty' -> go ty'+ Flexi -> defer ty }++ -- In all other cases we bale out into ordinary unification+ -- However unlike the meta-tyvar case, we are sure that the+ -- number of arguments doesn't match arity of the original+ -- type, so we can add a bit more context to the error message+ -- (cf #7869).+ --+ -- It is not always an error, because specialized type may have+ -- different arity, for example:+ --+ -- > f1 = f2 'a'+ -- > f2 :: Monad m => m Bool+ -- > f2 = undefined+ --+ -- But in that case we add specialized type into error context+ -- anyway, because it may be useful. See also #9605.+ go ty = addErrCtxtM (mk_ctxt ty) (defer ty)++ ------------+ defer fun_ty+ = do { arg_ty <- newOpenFlexiTyVarTy+ ; res_ty <- newOpenFlexiTyVarTy+ ; let unif_fun_ty = mkVisFunTyMany arg_ty res_ty+ ; co <- unifyType mb_thing fun_ty unif_fun_ty+ ; return (mkWpCastN co, unrestricted arg_ty, res_ty) }++ ------------+ mk_ctxt :: TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc)+ mk_ctxt res_ty env = mkFunTysMsg env herald (reverse arg_tys_so_far)+ res_ty n_val_args_in_call+ (n_val_args_in_call, arg_tys_so_far) = err_info++{- Note [matchActualFunTy error handling]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+matchActualFunTySigma is made much more complicated by the+desire to produce good error messages. Consider the application+ f @Int x y+In GHC.Tc.Gen.Expr.tcArgs we deal with visible type arguments,+and then call matchActualFunTysPart for each individual value+argument. It, in turn, must instantiate any type/dictionary args,+before looking for an arrow type.++But if it doesn't find an arrow type, it wants to generate a message+like "f is applied to two arguments but its type only has one".+To do that, it needs to konw about the args that tcArgs has already+munched up -- hence passing in n_val_args_in_call and arg_tys_so_far;+and hence also the accumulating so_far arg to 'go'.++This allows us (in mk_ctxt) to construct f's /instantiated/ type,+with just the values-arg arrows, which is what we really want+in the error message.++Ugh!+-}++-- Like 'matchExpectedFunTys', but used when you have an "actual" type,+-- for example in function application+matchActualFunTysRho :: SDoc -- See Note [Herald for matchExpectedFunTys]+ -> CtOrigin+ -> Maybe SDoc -- the thing with type TcSigmaType+ -> Arity+ -> TcSigmaType+ -> TcM (HsWrapper, [Scaled TcSigmaType], TcRhoType)+-- If matchActualFunTysRho n ty = (wrap, [t1,..,tn], res_ty)+-- then wrap : ty ~> (t1 -> ... -> tn -> res_ty)+-- and res_ty is a RhoType+-- NB: the returned type is top-instantiated; it's a RhoType+matchActualFunTysRho herald ct_orig mb_thing n_val_args_wanted fun_ty+ = go n_val_args_wanted [] fun_ty+ where+ go n so_far fun_ty+ | not (isRhoTy fun_ty)+ = do { (wrap1, rho) <- topInstantiate ct_orig fun_ty+ ; (wrap2, arg_tys, res_ty) <- go n so_far rho+ ; return (wrap2 <.> wrap1, arg_tys, res_ty) }++ go 0 _ fun_ty = return (idHsWrapper, [], fun_ty)++ go n so_far fun_ty+ = do { (wrap_fun1, arg_ty1, res_ty1) <- matchActualFunTySigma+ herald mb_thing+ (n_val_args_wanted, so_far)+ fun_ty+ ; (wrap_res, arg_tys, res_ty) <- go (n-1) (arg_ty1:so_far) res_ty1+ ; let wrap_fun2 = mkWpFun idHsWrapper wrap_res arg_ty1 res_ty doc+ ; return (wrap_fun2 <.> wrap_fun1, arg_ty1:arg_tys, res_ty) }+ where+ doc = text "When inferring the argument type of a function with type" <+>+ quotes (ppr fun_ty)++ {- ************************************************************************ * *@@ -226,167 +368,32 @@ ------------ mk_ctxt :: [Scaled ExpSigmaType] -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc) mk_ctxt arg_tys res_ty env- = do { (env', ty) <- zonkTidyTcType env (mkVisFunTys arg_tys' res_ty)- ; return ( env', mk_fun_tys_msg herald ty arity) }+ = mkFunTysMsg env herald arg_tys' res_ty arity where- arg_tys' = map (\(Scaled u v) -> Scaled u (checkingExpType "matchExpectedFunTys" v)) (reverse arg_tys)+ arg_tys' = map (\(Scaled u v) -> Scaled u (checkingExpType "matchExpectedFunTys" v)) $+ reverse arg_tys -- this is safe b/c we're called from "go" --- Like 'matchExpectedFunTys', but used when you have an "actual" type,--- for example in function application-matchActualFunTysRho :: SDoc -- See Note [Herald for matchExpectedFunTys]- -> CtOrigin- -> Maybe (HsExpr GhcRn) -- the thing with type TcSigmaType- -> Arity- -> TcSigmaType- -> TcM (HsWrapper, [Scaled TcSigmaType], TcRhoType)--- If matchActualFunTysRho n ty = (wrap, [t1,..,tn], res_ty)--- then wrap : ty ~> (t1 -> ... -> tn -> res_ty)--- and res_ty is a RhoType--- NB: the returned type is top-instantiated; it's a RhoType-matchActualFunTysRho herald ct_orig mb_thing n_val_args_wanted fun_ty- = go n_val_args_wanted [] fun_ty- where- go 0 _ fun_ty- = do { (wrap, rho) <- topInstantiate ct_orig fun_ty- ; return (wrap, [], rho) }- go n so_far fun_ty- = do { (wrap_fun1, arg_ty1, res_ty1) <- matchActualFunTySigma- herald ct_orig mb_thing- (n_val_args_wanted, so_far)- fun_ty- ; (wrap_res, arg_tys, res_ty) <- go (n-1) (arg_ty1:so_far) res_ty1- ; let wrap_fun2 = mkWpFun idHsWrapper wrap_res arg_ty1 res_ty doc- ; return (wrap_fun2 <.> wrap_fun1, arg_ty1:arg_tys, res_ty) }- where- doc = text "When inferring the argument type of a function with type" <+>- quotes (ppr fun_ty)---- | matchActualFunTySigm does looks for just one function arrow--- returning an uninstantiated sigma-type-matchActualFunTySigma- :: SDoc -- See Note [Herald for matchExpectedFunTys]- -> CtOrigin- -> Maybe (HsExpr GhcRn) -- The thing with type TcSigmaType- -> (Arity, [Scaled TcSigmaType]) -- Total number of value args in the call, and- -- types of values args to which function has- -- been applied already (reversed)- -- Both are used only for error messages)- -> TcSigmaType -- Type to analyse- -> TcM (HsWrapper, Scaled TcSigmaType, TcSigmaType)--- See Note [matchActualFunTys error handling] for all these arguments---- If (wrap, arg_ty, res_ty) = matchActualFunTySigma ... fun_ty--- then wrap :: fun_ty ~> (arg_ty -> res_ty)--- and NB: res_ty is an (uninstantiated) SigmaType--matchActualFunTySigma herald ct_orig mb_thing err_info fun_ty- = go fun_ty--- Does not allocate unnecessary meta variables: if the input already is--- a function, we just take it apart. Not only is this efficient,--- it's important for higher rank: the argument might be of form--- (forall a. ty) -> other--- If allocated (fresh-meta-var1 -> fresh-meta-var2) and unified, we'd--- hide the forall inside a meta-variable---- (*) Sometimes it's necessary to call matchActualFunTys with only part--- (that is, to the right of some arrows) of the type of the function in--- question. (See GHC.Tc.Gen.Expr.tcArgs.) This argument is the reversed list of--- arguments already seen (that is, not part of the TcSigmaType passed--- in elsewhere).-- where- go :: TcSigmaType -- The remainder of the type as we're processing- -> TcM (HsWrapper, Scaled TcSigmaType, TcSigmaType)- go ty | Just ty' <- tcView ty = go ty'-- go ty- | not (null tvs && null theta)- = do { (wrap1, rho) <- topInstantiate ct_orig ty- ; (wrap2, arg_ty, res_ty) <- go rho- ; return (wrap2 <.> wrap1, arg_ty, res_ty) }- where- (tvs, theta, _) = tcSplitSigmaTy ty-- go (FunTy { ft_af = af, ft_mult = w, ft_arg = arg_ty, ft_res = res_ty })- = ASSERT( af == VisArg )- return (idHsWrapper, Scaled w arg_ty, res_ty)-- go ty@(TyVarTy tv)- | isMetaTyVar tv- = do { cts <- readMetaTyVar tv- ; case cts of- Indirect ty' -> go ty'- Flexi -> defer ty }-- -- In all other cases we bale out into ordinary unification- -- However unlike the meta-tyvar case, we are sure that the- -- number of arguments doesn't match arity of the original- -- type, so we can add a bit more context to the error message- -- (cf #7869).- --- -- It is not always an error, because specialized type may have- -- different arity, for example:- --- -- > f1 = f2 'a'- -- > f2 :: Monad m => m Bool- -- > f2 = undefined- --- -- But in that case we add specialized type into error context- -- anyway, because it may be useful. See also #9605.- go ty = addErrCtxtM (mk_ctxt ty) (defer ty)-- ------------- defer fun_ty- = do { arg_ty <- newOpenFlexiTyVarTy- ; res_ty <- newOpenFlexiTyVarTy- ; let unif_fun_ty = mkVisFunTyMany arg_ty res_ty- ; co <- unifyType mb_thing fun_ty unif_fun_ty- ; return (mkWpCastN co, unrestricted arg_ty, res_ty) }-- ------------- mk_ctxt :: TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc)- mk_ctxt res_ty env- = do { (env', ty) <- zonkTidyTcType env $- mkVisFunTys (reverse arg_tys_so_far) res_ty- ; return (env', mk_fun_tys_msg herald ty n_val_args_in_call) }- (n_val_args_in_call, arg_tys_so_far) = err_info--mk_fun_tys_msg :: SDoc -> TcType -> Arity -> SDoc-mk_fun_tys_msg herald ty n_args_in_call- | n_args_in_call <= n_fun_args -- Enough args, in the end- = text "In the result of a function call"- | otherwise- = hang (herald <+> speakNOf n_args_in_call (text "value argument") <> comma)- 2 (sep [ text "but its type" <+> quotes (pprType ty)- , if n_fun_args == 0 then text "has none"- else text "has only" <+> speakN n_fun_args])- where- (args, _) = tcSplitFunTys ty- n_fun_args = length args--{- Note [matchActualFunTys error handling]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-matchActualFunTysPart is made much more complicated by the-desire to produce good error messages. Consider the application- f @Int x y-In GHC.Tc.Gen.Expr.tcArgs we deal with visible type arguments,-and then call matchActualFunTysPart for each individual value-argument. It, in turn, must instantiate any type/dictionary args,-before looking for an arrow type.+mkFunTysMsg :: TidyEnv -> SDoc -> [Scaled TcType] -> TcType -> Arity+ -> TcM (TidyEnv, MsgDoc)+mkFunTysMsg env herald arg_tys res_ty n_val_args_in_call+ = do { (env', fun_rho) <- zonkTidyTcType env $+ mkVisFunTys arg_tys res_ty -But if it doesn't find an arrow type, it wants to generate a message-like "f is applied to two arguments but its type only has one".-To do that, it needs to konw about the args that tcArgs has already-munched up -- hence passing in n_val_args_in_call and arg_tys_so_far;-and hence also the accumulating so_far arg to 'go'.+ ; let (all_arg_tys, _) = splitFunTys fun_rho+ n_fun_args = length all_arg_tys -This allows us (in mk_ctxt) to construct f's /instantiated/ type,-with just the values-arg arrows, which is what we really want-in the error message.+ msg | n_val_args_in_call <= n_fun_args -- Enough args, in the end+ = text "In the result of a function call"+ | otherwise+ = hang (full_herald <> comma)+ 2 (sep [ text "but its type" <+> quotes (pprType fun_rho)+ , if n_fun_args == 0 then text "has none"+ else text "has only" <+> speakN n_fun_args]) -Ugh!--}+ ; return (env', msg) }+ where+ full_herald = herald <+> speakNOf n_val_args_in_call (text "value argument") ---------------------- matchExpectedListTy :: TcRhoType -> TcM (TcCoercionN, TcRhoType)@@ -519,7 +526,7 @@ tcWrapResultO orig rn_expr expr actual_ty res_ty = do { traceTc "tcWrapResult" (vcat [ text "Actual: " <+> ppr actual_ty , text "Expected:" <+> ppr res_ty ])- ; wrap <- tcSubTypeNC orig GenSigCtxt (Just rn_expr) actual_ty res_ty+ ; wrap <- tcSubTypeNC orig GenSigCtxt (Just (ppr rn_expr)) actual_ty res_ty ; return (mkHsWrap wrap expr) } tcWrapResultMono :: HsExpr GhcRn -> HsExpr GhcTc@@ -533,7 +540,7 @@ = ASSERT2( isRhoTy act_ty, ppr act_ty $$ ppr rn_expr ) do { co <- case res_ty of Infer inf_res -> fillInferResult act_ty inf_res- Check exp_ty -> unifyType (Just rn_expr) act_ty exp_ty+ Check exp_ty -> unifyType (Just (ppr rn_expr)) act_ty exp_ty ; return (mkHsWrapCo co expr) } ------------------------@@ -565,7 +572,7 @@ tcSubTypeNC :: CtOrigin -- Used when instantiating -> UserTypeCtxt -- Used when skolemising- -> Maybe (HsExpr GhcRn) -- The expression that has type 'actual' (if known)+ -> Maybe SDoc -- The expression that has type 'actual' (if known) -> TcSigmaType -- Actual type -> ExpRhoType -- Expected type -> TcM HsWrapper@@ -661,12 +668,7 @@ ; return (sk_wrap <.> inner_wrap) } where- possibly_poly ty- | isForAllTy ty = True- | Just (_, _, res) <- splitFunTy_maybe ty = possibly_poly res- | otherwise = False- -- NB *not* tcSplitFunTy, because here we want- -- to decompose type-class arguments too+ possibly_poly ty = not (isRhoTy ty) definitely_poly ty | (tvs, theta, tau) <- tcSplitSigmaTy ty@@ -719,9 +721,6 @@ then we can revert to simple equality. But we need to be careful. These examples are all fine: - * (Char -> forall a. a->a) <= (forall a. Char -> a -> a)- Polymorphism is buried in ty_actual- * (Char->Char) <= (forall a. Char -> Char) ty_expected isn't really polymorphic @@ -832,10 +831,11 @@ tcSkolemiseScoped is very similar, but differs in two ways: -* It deals specially with just the outer forall, bringing those- type variables into lexical scope. To my surprise, I found that- doing this regardless (in tcSkolemise) caused a non-trivial (1%-ish)- perf hit on the compiler.+* It deals specially with just the outer forall, bringing those type+ variables into lexical scope. To my surprise, I found that doing+ this unconditionally in tcSkolemise (i.e. doing it even if we don't+ need to bring the variables into lexical scope, which is harmless)+ caused a non-trivial (1%-ish) perf hit on the compiler. * It always calls checkConstraints, even if there are no skolem variables at all. Reason: there might be nested deferred errors@@ -848,6 +848,8 @@ -> (TcType -> TcM result) -> TcM (HsWrapper, result) -- ^ The wrapper has type: spec_ty ~> expected_ty+-- See Note [Skolemisation] for the differences between+-- tcSkolemiseScoped and tcSkolemise tcSkolemiseScoped ctxt expected_ty thing_inside = do { (wrap, tv_prs, given, rho_ty) <- topSkolemise expected_ty@@ -1039,7 +1041,7 @@ [W] C Int b2 -- from g_blan and fundpes can yield [D] b1 ~ b2, even though the two functions have literally nothing to do with each other. #14185 is an example.- Building an implication keeps them separage.+ Building an implication keeps them separate. -} {-@@ -1053,8 +1055,9 @@ non-exported generic functions. -} -unifyType :: Maybe (HsExpr GhcRn) -- ^ If present, has type 'ty1'- -> TcTauType -> TcTauType -> TcM TcCoercionN+unifyType :: Maybe SDoc -- ^ If present, the thing that has type ty1+ -> TcTauType -> TcTauType -- ty1, ty2+ -> TcM TcCoercionN -- :: ty1 ~# ty2 -- Actual and expected types -- Returns a coercion : ty1 ~ ty2 unifyType thing ty1 ty2@@ -1077,13 +1080,13 @@ , uo_visible = True } -unifyKind :: Maybe (HsType GhcRn) -> TcKind -> TcKind -> TcM CoercionN-unifyKind thing ty1 ty2+unifyKind :: Maybe SDoc -> TcKind -> TcKind -> TcM CoercionN+unifyKind mb_thing ty1 ty2 = uType KindLevel origin ty1 ty2 where origin = TypeEqOrigin { uo_actual = ty1 , uo_expected = ty2- , uo_thing = ppr <$> thing+ , uo_thing = mb_thing , uo_visible = True } @@ -1186,10 +1189,12 @@ | Just ty1' <- tcView ty1 = go ty1' ty2 | Just ty2' <- tcView ty2 = go ty1 ty2' - -- Functions (or predicate functions) just check the two parts- go (FunTy _ w1 fun1 arg1) (FunTy _ w2 fun2 arg2)- = do { co_l <- uType t_or_k origin fun1 fun2- ; co_r <- uType t_or_k origin arg1 arg2+ -- Functions (t1 -> t2) just check the two parts+ -- Do not attempt (c => t); just defer+ go (FunTy { ft_af = VisArg, ft_mult = w1, ft_arg = arg1, ft_res = res1 })+ (FunTy { ft_af = VisArg, ft_mult = w2, ft_arg = arg2, ft_res = res2 })+ = do { co_l <- uType t_or_k origin arg1 arg2+ ; co_r <- uType t_or_k origin res1 res2 ; co_w <- uType t_or_k origin w1 w2 ; return $ mkFunCo Nominal co_w co_l co_r } @@ -1479,6 +1484,7 @@ lhsPriority :: TcTyVar -> Int -- Higher => more important to be on the LHS+-- => more likely to be eliminated -- See Note [TyVar/TyVar orientation] lhsPriority tv = ASSERT2( isTyVar tv, ppr tv)@@ -1486,10 +1492,12 @@ RuntimeUnk -> 0 SkolemTv {} -> 0 MetaTv { mtv_info = info } -> case info of- FlatSkolTv -> 1- TyVarTv -> 2- TauTv -> 3- FlatMetaTv -> 4+ FlatSkolTv -> 1+ TyVarTv -> 2+ TauTv -> 3+ FlatMetaTv -> 4+ RuntimeUnkTv -> 5+ {- Note [TyVar/TyVar orientation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Given (a ~ b), should we orient the CTyEqCan as (a~b) or (b~a)?@@ -1855,7 +1863,7 @@ Indirect fun_kind -> go n fun_kind Flexi -> defer n k } - go n (FunTy _ w arg res)+ go n (FunTy { ft_mult = w, ft_arg = arg, ft_res = res }) = do { co <- go (n-1) res ; return (mkTcFunCo Nominal (mkTcNomReflCo w) (mkTcNomReflCo arg) co) } @@ -1943,7 +1951,7 @@ -- a) the given variable occurs in the given type. -- b) there is a forall in the type (unless we have -XImpredicativeTypes) occCheckForErrors dflags tv ty- = case preCheck dflags True tv ty of+ = case mtvu_check dflags True tv ty of MTVU_OK _ -> MTVU_OK () MTVU_Bad -> MTVU_Bad MTVU_HoleBlocker -> MTVU_HoleBlocker@@ -1957,13 +1965,20 @@ -> TcType -- ty :: k2 -> MetaTyVarUpdateResult TcType -- possibly-expanded ty -- (metaTyVarUpdateOK tv ty)--- We are about to update the meta-tyvar tv with ty--- Check (a) that tv doesn't occur in ty (occurs check)+-- Checks that the equality tv~ty is OK to be used to rewrite+-- other equalities. Equivalently, checks the conditions for CTyEqCan+-- (a) that tv doesn't occur in ty (occurs check) -- (b) that ty does not have any foralls -- (in the impredicative case), or type functions -- (c) that ty does not have any blocking coercion holes -- See Note [Equalities with incompatible kinds] in "GHC.Tc.Solver.Canonical" --+-- Used in two places:+-- - In the eager unifier: uUnfilledVar2+-- - In the canonicaliser: GHC.Tc.Solver.Canonical.canEqTyVar2+-- Note that in the latter case tv is not necessarily a meta-tyvar,+-- despite the name of this function.+ -- We have two possible outcomes: -- (1) Return the type to update the type variable with, -- [we know the update is ok]@@ -1982,7 +1997,7 @@ -- See Note [Refactoring hazard: checkTauTvUpdate] metaTyVarUpdateOK dflags tv ty- = case preCheck dflags False tv ty of+ = case mtvu_check dflags False tv ty of -- False <=> type families not ok -- See Note [Prevent unification with type families] MTVU_OK _ -> MTVU_OK ty@@ -1992,11 +2007,11 @@ Just expanded_ty -> MTVU_OK expanded_ty Nothing -> MTVU_Occurs -preCheck :: DynFlags -> Bool -> TcTyVar -> TcType -> MetaTyVarUpdateResult ()--- A quick check for--- (a) a forall type (unless -XImpredicativeTypes)--- (b) a predicate type (unless -XImpredicativeTypes)--- (c) a type family+mtvu_check :: DynFlags -> Bool -> TcTyVar -> TcType -> MetaTyVarUpdateResult ()+-- Checks the invariants for CTyEqCan. In particular:+-- (a) a forall type (forall a. blah)+-- (b) a predicate type (c => ty)+-- (c) a type family; see Note [Prevent unification with type families] -- (d) a blocking coercion hole -- (e) an occurrence of the type variable (occurs check) --@@ -2004,15 +2019,20 @@ -- inside the kinds of variables it mentions. For (d) we look deeply -- in coercions, and for (e) we do look in the kinds of course. -preCheck dflags ty_fam_ok tv ty+mtvu_check dflags ty_fam_ok tv ty = fast_check ty where- details = tcTyVarDetails tv- impredicative_ok = canUnifyWithPolyType dflags details- ok :: MetaTyVarUpdateResult () ok = MTVU_OK () + -- The GHCi runtime debugger does its type-matching with+ -- unification variables that can unify with a polytype+ -- or a TyCon that would usually be disallowed by bad_tc+ -- See Note [RuntimeUnkTv] in GHC.Runtime.Heap.Inspect+ ghci_tv = case tcTyVarDetails tv of+ MetaTv { mtv_info = RuntimeUnkTv } -> True+ _ -> False+ fast_check :: TcType -> MetaTyVarUpdateResult () fast_check (TyVarTy tv') | tv == tv' = MTVU_Occurs@@ -2021,19 +2041,19 @@ -- in GHC.Core.Type fast_check (TyConApp tc tys)- | bad_tc tc = MTVU_Bad+ | bad_tc tc, not ghci_tv = MTVU_Bad | otherwise = mapM fast_check tys >> ok fast_check (LitTy {}) = ok fast_check (FunTy{ft_af = af, ft_mult = w, ft_arg = a, ft_res = r}) | InvisArg <- af- , not impredicative_ok = MTVU_Bad+ , not ghci_tv = MTVU_Bad | otherwise = fast_check w >> fast_check a >> fast_check r fast_check (AppTy fun arg) = fast_check fun >> fast_check arg fast_check (CastTy ty co) = fast_check ty >> fast_check_co co fast_check (CoercionTy co) = fast_check_co co fast_check (ForAllTy (Bndr tv' _) ty)- | not impredicative_ok = MTVU_Bad- | tv == tv' = ok+ | not ghci_tv = MTVU_Bad+ | tv == tv' = ok | otherwise = do { fast_check_occ (tyVarKind tv') ; fast_check_occ ty } -- Under a forall we look only for occurrences of@@ -2056,14 +2076,6 @@ bad_tc :: TyCon -> Bool bad_tc tc- | not (impredicative_ok || isTauTyCon tc) = True- | not (ty_fam_ok || isFamFreeTyCon tc) = True- | otherwise = False--canUnifyWithPolyType :: DynFlags -> TcTyVarDetails -> Bool-canUnifyWithPolyType dflags details- = case details of- MetaTv { mtv_info = TyVarTv } -> False- MetaTv { mtv_info = TauTv } -> xopt LangExt.ImpredicativeTypes dflags- _other -> True- -- We can have non-meta tyvars in given constraints+ | not (isTauTyCon tc) = True+ | not (ty_fam_ok || isFamFreeTyCon tc) = True+ | otherwise = False
compiler/GHC/Tc/Utils/Unify.hs-boot view
@@ -5,14 +5,14 @@ import GHC.Tc.Types ( TcM ) import GHC.Tc.Types.Evidence ( TcCoercion, HsWrapper ) import GHC.Tc.Types.Origin ( CtOrigin )-import GHC.Hs.Expr ( HsExpr )-import GHC.Hs.Type ( HsType, Mult )-import GHC.Hs.Extension ( GhcRn )+import GHC.Utils.Outputable( SDoc )+import GHC.Hs.Type ( Mult ) + -- This boot file exists only to tie the knot between -- GHC.Tc.Utils.Unify and Inst -unifyType :: Maybe (HsExpr GhcRn) -> TcTauType -> TcTauType -> TcM TcCoercion-unifyKind :: Maybe (HsType GhcRn) -> TcTauType -> TcTauType -> TcM TcCoercion+unifyType :: Maybe SDoc -> TcTauType -> TcTauType -> TcM TcCoercion+unifyKind :: Maybe SDoc -> TcTauType -> TcTauType -> TcM TcCoercion tcSubMult :: CtOrigin -> Mult -> Mult -> TcM HsWrapper
compiler/GHC/Tc/Utils/Zonk.hs view
@@ -723,6 +723,14 @@ = ASSERT2( isNothing (isDataConId_maybe id), ppr id ) return (HsVar x (L l (zonkIdOcc env id))) +zonkExpr env (HsUnboundVar v occ)+ = return (HsUnboundVar (zonkIdOcc env v) occ)++zonkExpr env (HsRecFld _ (Ambiguous v occ))+ = return (HsRecFld noExtField (Ambiguous (zonkIdOcc env v) occ))+zonkExpr env (HsRecFld _ (Unambiguous v occ))+ = return (HsRecFld noExtField (Unambiguous (zonkIdOcc env v) occ))+ zonkExpr _ e@(HsConLikeOut {}) = return e zonkExpr _ (HsIPVar x id)@@ -914,9 +922,6 @@ zonkExpr env (XExpr (ExpansionExpr (HsExpanded a b))) = XExpr . ExpansionExpr . HsExpanded a <$> zonkExpr env b--zonkExpr _ e@(HsUnboundVar {})- = return e zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
compiler/GHC/Tc/Validity.hs view
@@ -14,7 +14,7 @@ checkValidInstance, checkValidInstHead, validDerivPred, checkTySynRhs, checkValidCoAxiom, checkValidCoAxBranch,- checkValidTyFamEqn, checkConsistentFamInst,+ checkValidTyFamEqn, checkValidAssocTyFamDeflt, checkConsistentFamInst, badATErr, arityErr, checkTyConTelescope, allDistinctTyVars@@ -73,6 +73,7 @@ import Control.Monad import Data.Foldable+import Data.Function import Data.List ( (\\), nub ) import qualified Data.List.NonEmpty as NE @@ -347,7 +348,6 @@ rank = case ctxt of DefaultDeclCtxt-> MustBeMonoType- ResSigCtxt -> MustBeMonoType PatSigCtxt -> rank0 RuleSigCtxt _ -> rank1 TySynCtxt _ -> rank0@@ -371,7 +371,6 @@ ForSigCtxt _ -> rank1 SpecInstCtxt -> rank1- ThBrackCtxt -> rank1 GhciCtxt {} -> ArbitraryRank TyVarBndrKindCtxt _ -> rank0@@ -457,7 +456,7 @@ rankZeroMonoType, tyConArgMonoType, synArgMonoType, constraintMonoType :: Rank rankZeroMonoType = MonoType (text "Perhaps you intended to use RankNTypes")-tyConArgMonoType = MonoType (text "GHC doesn't yet support impredicative polymorphism")+tyConArgMonoType = MonoType (text "Perhaps you intended to use ImpredicativeTypes") synArgMonoType = MonoType (text "Perhaps you intended to use LiberalTypeSynonyms") constraintMonoType = MonoType (vcat [ text "A constraint must be a monotype" , text "Perhaps you intended to use QuantifiedConstraints" ])@@ -471,18 +470,81 @@ forAllAllowed (LimitedRank forall_ok _) = forall_ok forAllAllowed _ = False +-- | Indicates whether a 'UserTypeCtxt' represents type-level contexts,+-- kind-level contexts, or both.+data TypeOrKindCtxt+ = OnlyTypeCtxt+ -- ^ A 'UserTypeCtxt' that only represents type-level positions.+ | OnlyKindCtxt+ -- ^ A 'UserTypeCtxt' that only represents kind-level positions.+ | BothTypeAndKindCtxt+ -- ^ A 'UserTypeCtxt' that can represent both type- and kind-level positions.+ deriving Eq++instance Outputable TypeOrKindCtxt where+ ppr ctxt = text $ case ctxt of+ OnlyTypeCtxt -> "OnlyTypeCtxt"+ OnlyKindCtxt -> "OnlyKindCtxt"+ BothTypeAndKindCtxt -> "BothTypeAndKindCtxt"++-- | Determine whether a 'UserTypeCtxt' can represent type-level contexts,+-- kind-level contexts, or both.+typeOrKindCtxt :: UserTypeCtxt -> TypeOrKindCtxt+typeOrKindCtxt (FunSigCtxt {}) = OnlyTypeCtxt+typeOrKindCtxt (InfSigCtxt {}) = OnlyTypeCtxt+typeOrKindCtxt (ExprSigCtxt {}) = OnlyTypeCtxt+typeOrKindCtxt (TypeAppCtxt {}) = OnlyTypeCtxt+typeOrKindCtxt (PatSynCtxt {}) = OnlyTypeCtxt+typeOrKindCtxt (PatSigCtxt {}) = OnlyTypeCtxt+typeOrKindCtxt (RuleSigCtxt {}) = OnlyTypeCtxt+typeOrKindCtxt (ForSigCtxt {}) = OnlyTypeCtxt+typeOrKindCtxt (DefaultDeclCtxt {}) = OnlyTypeCtxt+typeOrKindCtxt (InstDeclCtxt {}) = OnlyTypeCtxt+typeOrKindCtxt (SpecInstCtxt {}) = OnlyTypeCtxt+typeOrKindCtxt (GenSigCtxt {}) = OnlyTypeCtxt+typeOrKindCtxt (ClassSCCtxt {}) = OnlyTypeCtxt+typeOrKindCtxt (SigmaCtxt {}) = OnlyTypeCtxt+typeOrKindCtxt (DataTyCtxt {}) = OnlyTypeCtxt+typeOrKindCtxt (DerivClauseCtxt {}) = OnlyTypeCtxt+typeOrKindCtxt (ConArgCtxt {}) = OnlyTypeCtxt+ -- Although data constructors can be promoted with DataKinds, we always+ -- validity-check them as though they are the types of terms. We may need+ -- to revisit this decision if we ever allow visible dependent quantification+ -- in the types of data constructors.++typeOrKindCtxt (KindSigCtxt {}) = OnlyKindCtxt+typeOrKindCtxt (StandaloneKindSigCtxt {}) = OnlyKindCtxt+typeOrKindCtxt (TyVarBndrKindCtxt {}) = OnlyKindCtxt+typeOrKindCtxt (DataKindCtxt {}) = OnlyKindCtxt+typeOrKindCtxt (TySynKindCtxt {}) = OnlyKindCtxt+typeOrKindCtxt (TyFamResKindCtxt {}) = OnlyKindCtxt++typeOrKindCtxt (TySynCtxt {}) = BothTypeAndKindCtxt+ -- Type synonyms can have types and kinds on their RHSs+typeOrKindCtxt (GhciCtxt {}) = BothTypeAndKindCtxt+ -- GHCi's :kind command accepts both types and kinds++-- | Returns 'True' if the supplied 'UserTypeCtxt' is unambiguously not the+-- context for a kind of a type, where the arbitrary use of constraints is+-- currently disallowed.+-- (See @Note [Constraints in kinds]@ in "GHC.Core.TyCo.Rep".)+-- If the 'UserTypeCtxt' can refer to both types and kinds, this function+-- conservatively returns 'True'.+--+-- An example of something that is unambiguously the kind of a type is the+-- @Show a => a -> a@ in @type Foo :: Show a => a -> a@. On the other hand, the+-- same type in @foo :: Show a => a -> a@ is unambiguously the type of a term,+-- not the kind of a type, so it is permitted. allConstraintsAllowed :: UserTypeCtxt -> Bool--- We don't allow arbitrary constraints in kinds-allConstraintsAllowed (TyVarBndrKindCtxt {}) = False-allConstraintsAllowed (DataKindCtxt {}) = False-allConstraintsAllowed (TySynKindCtxt {}) = False-allConstraintsAllowed (TyFamResKindCtxt {}) = False-allConstraintsAllowed (StandaloneKindSigCtxt {}) = False-allConstraintsAllowed _ = True+allConstraintsAllowed ctxt = case typeOrKindCtxt ctxt of+ OnlyTypeCtxt -> True+ OnlyKindCtxt -> False+ BothTypeAndKindCtxt -> True -- | Returns 'True' if the supplied 'UserTypeCtxt' is unambiguously not the -- context for the type of a term, where visible, dependent quantification is--- currently disallowed.+-- currently disallowed. If the 'UserTypeCtxt' can refer to both types and+-- kinds, this function conservatively returns 'True'. -- -- An example of something that is unambiguously the type of a term is the -- @forall a -> a -> a@ in @foo :: forall a -> a -> a@. On the other hand, the@@ -495,40 +557,10 @@ -- @testsuite/tests/dependent/should_fail/T16326_Fail*.hs@ (for places where -- VDQ is disallowed). vdqAllowed :: UserTypeCtxt -> Bool--- Currently allowed in the kinds of types...-vdqAllowed (KindSigCtxt {}) = True-vdqAllowed (StandaloneKindSigCtxt {}) = True-vdqAllowed (TySynCtxt {}) = True-vdqAllowed (ThBrackCtxt {}) = True-vdqAllowed (GhciCtxt {}) = True-vdqAllowed (TyVarBndrKindCtxt {}) = True-vdqAllowed (DataKindCtxt {}) = True-vdqAllowed (TySynKindCtxt {}) = True-vdqAllowed (TyFamResKindCtxt {}) = True--- ...but not in the types of terms.-vdqAllowed (ConArgCtxt {}) = False- -- We could envision allowing VDQ in data constructor types so long as the- -- constructor is only ever used at the type level, but for now, GHC adopts- -- the stance that VDQ is never allowed in data constructor types.-vdqAllowed (FunSigCtxt {}) = False-vdqAllowed (InfSigCtxt {}) = False-vdqAllowed (ExprSigCtxt {}) = False-vdqAllowed (TypeAppCtxt {}) = False-vdqAllowed (PatSynCtxt {}) = False-vdqAllowed (PatSigCtxt {}) = False-vdqAllowed (RuleSigCtxt {}) = False-vdqAllowed (ResSigCtxt {}) = False-vdqAllowed (ForSigCtxt {}) = False-vdqAllowed (DefaultDeclCtxt {}) = False--- We count class constraints as "types of terms". All of the cases below deal--- with class constraints.-vdqAllowed (InstDeclCtxt {}) = False-vdqAllowed (SpecInstCtxt {}) = False-vdqAllowed (GenSigCtxt {}) = False-vdqAllowed (ClassSCCtxt {}) = False-vdqAllowed (SigmaCtxt {}) = False-vdqAllowed (DataTyCtxt {}) = False-vdqAllowed (DerivClauseCtxt {}) = False+vdqAllowed ctxt = case typeOrKindCtxt ctxt of+ OnlyTypeCtxt -> False+ OnlyKindCtxt -> True+ BothTypeAndKindCtxt -> True {- Note [Correctness and performance of type synonym validity checking]@@ -1328,11 +1360,9 @@ okIPCtxt ExprSigCtxt = True okIPCtxt TypeAppCtxt = True okIPCtxt PatSigCtxt = True-okIPCtxt ResSigCtxt = True okIPCtxt GenSigCtxt = True okIPCtxt (ConArgCtxt {}) = True okIPCtxt (ForSigCtxt {}) = True -- ??-okIPCtxt ThBrackCtxt = True okIPCtxt (GhciCtxt {}) = True okIPCtxt SigmaCtxt = True okIPCtxt (DataTyCtxt {}) = True@@ -2116,6 +2146,68 @@ ; traceTc "checkVTFE" (ppr fam_tc $$ ppr rhs $$ ppr (tcTyFamInsts rhs)) ; unless undecidable_ok $ mapM_ addErrTc (checkFamInstRhs fam_tc typats (tcTyFamInsts rhs)) }++-- | Checks that an associated type family default:+--+-- 1. Only consists of arguments that are bare type variables, and+--+-- 2. Has a distinct type variable in each argument.+--+-- See @Note [Type-checking default assoc decls]@ in "GHC.Tc.TyCl".+checkValidAssocTyFamDeflt :: TyCon -- ^ of the type family+ -> [Type] -- ^ Type patterns+ -> TcM ()+checkValidAssocTyFamDeflt fam_tc pats =+ do { cpt_tvs <- zipWithM extract_tv pats pats_vis+ ; check_all_distinct_tvs $ zip cpt_tvs pats_vis }+ where+ pats_vis :: [ArgFlag]+ pats_vis = tyConArgFlags fam_tc pats++ -- Checks that a pattern on the LHS of a default is a type+ -- variable. If so, return the underlying type variable, and if+ -- not, throw an error.+ -- See Note [Type-checking default assoc decls]+ extract_tv :: Type -- The particular type pattern from which to extract+ -- its underlying type variable+ -> ArgFlag -- The visibility of the type pattern+ -- (only used for error message purposes)+ -> TcM TyVar+ extract_tv pat pat_vis =+ case getTyVar_maybe pat of+ Just tv -> pure tv+ Nothing -> failWithTc $+ pprWithExplicitKindsWhen (isInvisibleArgFlag pat_vis) $+ hang (text "Illegal argument" <+> quotes (ppr pat) <+> text "in:")+ 2 (vcat [ppr_eqn, suggestion])++ -- Checks that no type variables in an associated default declaration are+ -- duplicated. If that is the case, throw an error.+ -- See Note [Type-checking default assoc decls]+ check_all_distinct_tvs ::+ [(TyVar, ArgFlag)] -- The type variable arguments in the associated+ -- default declaration, along with their respective+ -- visibilities (the latter are only used for error+ -- message purposes)+ -> TcM ()+ check_all_distinct_tvs cpt_tvs_vis =+ let dups = findDupsEq ((==) `on` fst) cpt_tvs_vis in+ traverse_+ (\d -> let (pat_tv, pat_vis) = NE.head d in failWithTc $+ pprWithExplicitKindsWhen (isInvisibleArgFlag pat_vis) $+ hang (text "Illegal duplicate variable"+ <+> quotes (ppr pat_tv) <+> text "in:")+ 2 (vcat [ppr_eqn, suggestion]))+ dups++ ppr_eqn :: SDoc+ ppr_eqn =+ quotes (text "type" <+> ppr (mkTyConApp fam_tc pats)+ <+> equals <+> text "...")++ suggestion :: SDoc+ suggestion = text "The arguments to" <+> quotes (ppr fam_tc)+ <+> text "must all be distinct type variables" -- Make sure that each type family application is -- (1) strictly smaller than the lhs,
compiler/GHC/ThToHs.hs view
@@ -1393,12 +1393,25 @@ cvtPred :: TH.Pred -> CvtM (LHsType GhcPs) cvtPred = cvtType +cvtDerivClauseTys :: TH.Cxt -> CvtM (LDerivClauseTys GhcPs)+cvtDerivClauseTys tys+ = do { tys' <- mapM cvtType tys+ -- Since TH.Cxt doesn't indicate the presence or absence of+ -- parentheses in a deriving clause, we have to choose between+ -- DctSingle and DctMulti somewhat arbitrarily. We opt to use DctMulti+ -- unless the TH.Cxt is a singleton list whose type is a bare type+ -- constructor with no arguments.+ ; case tys' of+ [ty'@(L l (HsTyVar _ NotPromoted _))]+ -> return $ L l $ DctSingle noExtField $ mkLHsSigType ty'+ _ -> returnL $ DctMulti noExtField (map mkLHsSigType tys') }+ cvtDerivClause :: TH.DerivClause -> CvtM (LHsDerivingClause GhcPs)-cvtDerivClause (TH.DerivClause ds ctxt)- = do { ctxt' <- fmap (map mkLHsSigType) <$> cvtContext appPrec ctxt- ; ds' <- traverse cvtDerivStrategy ds- ; returnL $ HsDerivingClause noExtField ds' ctxt' }+cvtDerivClause (TH.DerivClause ds tys)+ = do { tys' <- cvtDerivClauseTys tys+ ; ds' <- traverse cvtDerivStrategy ds+ ; returnL $ HsDerivingClause noExtField ds' tys' } cvtDerivStrategy :: TH.DerivStrategy -> CvtM (Hs.LDerivStrategy GhcPs) cvtDerivStrategy TH.StockStrategy = returnL Hs.StockStrategy
+ compiler/GHC/Types/Unique/SDFM.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ApplicativeDo #-}+{-# OPTIONS_GHC -Wall #-}++-- | Like a 'UniqDFM', but maintains equivalence classes of keys sharing the+-- same entry. See 'UniqSDFM'.+module GHC.Types.Unique.SDFM (+ -- * Unique-keyed, /shared/, deterministic mappings+ UniqSDFM,++ emptyUSDFM,+ lookupUSDFM,+ equateUSDFM, addToUSDFM,+ traverseUSDFM+ ) where++import GHC.Prelude++import GHC.Types.Unique+import GHC.Types.Unique.DFM+import GHC.Utils.Outputable++-- | Either @Indirect x@, meaning the value is represented by that of @x@, or+-- an @Entry@ containing containing the actual value it represents.+data Shared key ele+ = Indirect !key+ | Entry !ele++-- | A 'UniqDFM' whose domain is /sets/ of 'Unique's, each of which share a+-- common value of type @ele@.+-- Every such set (\"equivalence class\") has a distinct representative+-- 'Unique'. Supports merging the entries of multiple such sets in a union-find+-- like fashion.+--+-- An accurate model is that of @[(Set key, Maybe ele)]@: A finite mapping from+-- sets of @key@s to possibly absent entries @ele@, where the sets don't overlap.+-- Example:+-- @+-- m = [({u1,u3}, Just ele1), ({u2}, Just ele2), ({u4,u7}, Nothing)]+-- @+-- On this model we support the following main operations:+--+-- * @'lookupUSDFM' m u3 == Just ele1@, @'lookupUSDFM' m u4 == Nothing@,+-- @'lookupUSDFM' m u5 == Nothing@.+-- * @'equateUSDFM' m u1 u3@ is a no-op, but+-- @'equateUSDFM' m u1 u2@ merges @{u1,u3}@ and @{u2}@ to point to+-- @Just ele2@ and returns the old entry of @{u1,u3}@, @Just ele1@.+-- * @'addToUSDFM' m u3 ele4@ sets the entry of @{u1,u3}@ to @Just ele4@.+--+-- As well as a few means for traversal/conversion to list.+newtype UniqSDFM key ele+ = USDFM { unUSDFM :: UniqDFM key (Shared key ele) }++emptyUSDFM :: UniqSDFM key ele+emptyUSDFM = USDFM emptyUDFM++lookupReprAndEntryUSDFM :: Uniquable key => UniqSDFM key ele -> key -> (key, Maybe ele)+lookupReprAndEntryUSDFM (USDFM env) = go+ where+ go x = case lookupUDFM env x of+ Nothing -> (x, Nothing)+ Just (Indirect y) -> go y+ Just (Entry ele) -> (x, Just ele)++-- | @lookupSUDFM env x@ looks up an entry for @x@, looking through all+-- 'Indirect's until it finds a shared 'Entry'.+--+-- Examples in terms of the model (see 'UniqSDFM'):+-- >>> lookupUSDFM [({u1,u3}, Just ele1), ({u2}, Just ele2)] u3 == Just ele1+-- >>> lookupUSDFM [({u1,u3}, Just ele1), ({u2}, Just ele2)] u4 == Nothing+-- >>> lookupUSDFM [({u1,u3}, Just ele1), ({u2}, Nothing)] u2 == Nothing+lookupUSDFM :: Uniquable key => UniqSDFM key ele -> key -> Maybe ele+lookupUSDFM usdfm x = snd (lookupReprAndEntryUSDFM usdfm x)++-- | @equateUSDFM env x y@ makes @x@ and @y@ point to the same entry,+-- thereby merging @x@'s class with @y@'s.+-- If both @x@ and @y@ are in the domain of the map, then @y@'s entry will be+-- chosen as the new entry and @x@'s old entry will be returned.+--+-- Examples in terms of the model (see 'UniqSDFM'):+-- >>> equateUSDFM [] u1 u2 == (Nothing, [({u1,u2}, Nothing)])+-- >>> equateUSDFM [({u1,u3}, Just ele1)] u3 u4 == (Nothing, [({u1,u3,u4}, Just ele1)])+-- >>> equateUSDFM [({u1,u3}, Just ele1)] u4 u3 == (Nothing, [({u1,u3,u4}, Just ele1)])+-- >>> equateUSDFM [({u1,u3}, Just ele1), ({u2}, Just ele2)] u3 u2 == (Just ele1, [({u2,u1,u3}, Just ele2)])+equateUSDFM+ :: Uniquable key => UniqSDFM key ele -> key -> key -> (Maybe ele, UniqSDFM key ele)+equateUSDFM usdfm@(USDFM env) x y =+ case (lu x, lu y) of+ ((x', _) , (y', _))+ | getUnique x' == getUnique y' -> (Nothing, usdfm) -- nothing to do+ ((x', _) , (_ , Nothing)) -> (Nothing, set_indirect y x')+ ((_ , mb_ex), (y', _)) -> (mb_ex, set_indirect x y')+ where+ lu = lookupReprAndEntryUSDFM usdfm+ set_indirect a b = USDFM $ addToUDFM env a (Indirect b)++-- | @addToUSDFM env x a@ sets the entry @x@ is associated with to @a@,+-- thereby modifying its whole equivalence class.+--+-- Examples in terms of the model (see 'UniqSDFM'):+-- >>> addToUSDFM [] u1 ele1 == [({u1}, Just ele1)]+-- >>> addToUSDFM [({u1,u3}, Just ele1)] u3 ele2 == [({u1,u3}, Just ele2)]+addToUSDFM :: Uniquable key => UniqSDFM key ele -> key -> ele -> UniqSDFM key ele+addToUSDFM usdfm@(USDFM env) x v =+ USDFM $ addToUDFM env (fst (lookupReprAndEntryUSDFM usdfm x)) (Entry v)++traverseUSDFM :: forall key a b f. Applicative f => (a -> f b) -> UniqSDFM key a -> f (UniqSDFM key b)+traverseUSDFM f = fmap (USDFM . listToUDFM_Directly) . traverse g . udfmToList . unUSDFM+ where+ g :: (Unique, Shared key a) -> f (Unique, Shared key b)+ g (u, Indirect y) = pure (u,Indirect y)+ g (u, Entry a) = do+ a' <- f a+ pure (u,Entry a')++instance (Outputable key, Outputable ele) => Outputable (Shared key ele) where+ ppr (Indirect x) = ppr x+ ppr (Entry a) = ppr a++instance (Outputable key, Outputable ele) => Outputable (UniqSDFM key ele) where+ ppr (USDFM env) = ppr env
compiler/GhclibHsVersions.h view
@@ -15,25 +15,25 @@ #define GLOBAL_VAR(name,value,ty) \ {-# NOINLINE name #-}; \ name :: IORef (ty); \-name = GHC.Utils.Misc.global (value);+name = GHC.Utils.GlobalVars.global (value); #define GLOBAL_VAR_M(name,value,ty) \ {-# NOINLINE name #-}; \ name :: IORef (ty); \-name = GHC.Utils.Misc.globalM (value);+name = GHC.Utils.GlobalVars.globalM (value); #define SHARED_GLOBAL_VAR(name,accessor,saccessor,value,ty) \ {-# NOINLINE name #-}; \ name :: IORef (ty); \-name = GHC.Utils.Misc.sharedGlobal (value) (accessor); \+name = GHC.Utils.GlobalVars.sharedGlobal (value) (accessor);\ foreign import ccall unsafe saccessor \ accessor :: Ptr (IORef a) -> IO (Ptr (IORef a)); #define SHARED_GLOBAL_VAR_M(name,accessor,saccessor,value,ty) \ {-# NOINLINE name #-}; \ name :: IORef (ty); \-name = GHC.Utils.Misc.sharedGlobalM (value) (accessor); \+name = GHC.Utils.GlobalVars.sharedGlobalM (value) (accessor); \ foreign import ccall unsafe saccessor \ accessor :: Ptr (IORef a) -> IO (Ptr (IORef a));
ghc-lib.cabal view
@@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib-version: 0.20200901+version: 0.20201001 license: BSD3 license-file: LICENSE category: Development@@ -38,7 +38,6 @@ ghc-lib/stage0/compiler/build/primop-vector-tys.hs-incl ghc-lib/stage0/compiler/build/primop-vector-uniques.hs-incl ghc-lib/stage0/compiler/build/primop-docs.hs-incl- ghc-lib/stage0/compiler/build/GHC/Platform/Constants.hs includes/ghcconfig.h includes/MachDeps.h includes/stg/MachRegs.h@@ -80,7 +79,7 @@ process >= 1 && < 1.7, hpc == 0.6.*, exceptions == 0.10.*,- ghc-lib-parser == 0.20200901+ ghc-lib-parser == 0.20201001 build-tools: alex >= 3.1, happy >= 1.19.4 other-extensions: BangPatterns@@ -117,6 +116,7 @@ UndecidableInstances default-extensions: BangPatterns+ MonoLocalBinds NoImplicitPrelude ScopedTypeVariables hs-source-dirs:@@ -184,6 +184,7 @@ GHC.Core.TyCon, GHC.Core.Type, GHC.Core.Unfold,+ GHC.Core.Unfold.Make, GHC.Core.Unify, GHC.Core.UsageEnv, GHC.Core.Utils,@@ -207,6 +208,7 @@ GHC.Driver.Backend, GHC.Driver.Backpack.Syntax, GHC.Driver.CmdLine,+ GHC.Driver.Config, GHC.Driver.Flags, GHC.Driver.Hooks, GHC.Driver.Monad,@@ -239,7 +241,6 @@ GHC.Hs.Pat, GHC.Hs.Type, GHC.Hs.Utils,- GHC.HsToCore.PmCheck.Types, GHC.Iface.Recomp.Binary, GHC.Iface.Syntax, GHC.Iface.Type,@@ -340,6 +341,7 @@ GHC.Utils.Exception, GHC.Utils.FV, GHC.Utils.Fingerprint,+ GHC.Utils.GlobalVars, GHC.Utils.IO.Unsafe, GHC.Utils.Json, GHC.Utils.Lexeme,@@ -531,10 +533,16 @@ GHC.HsToCore.Match.Constructor GHC.HsToCore.Match.Literal GHC.HsToCore.Monad- GHC.HsToCore.PmCheck- GHC.HsToCore.PmCheck.Oracle- GHC.HsToCore.PmCheck.Ppr+ GHC.HsToCore.Pmc+ GHC.HsToCore.Pmc.Check+ GHC.HsToCore.Pmc.Desugar+ GHC.HsToCore.Pmc.Ppr+ GHC.HsToCore.Pmc.Solver+ GHC.HsToCore.Pmc.Solver.Types+ GHC.HsToCore.Pmc.Types+ GHC.HsToCore.Pmc.Utils GHC.HsToCore.Quote+ GHC.HsToCore.Types GHC.HsToCore.Usage GHC.HsToCore.Utils GHC.Iface.Binary@@ -625,12 +633,14 @@ GHC.Tc.Errors GHC.Tc.Errors.Hole GHC.Tc.Gen.Annotation+ GHC.Tc.Gen.App GHC.Tc.Gen.Arrow GHC.Tc.Gen.Bind GHC.Tc.Gen.Default GHC.Tc.Gen.Export GHC.Tc.Gen.Expr GHC.Tc.Gen.Foreign+ GHC.Tc.Gen.Head GHC.Tc.Gen.HsType GHC.Tc.Gen.Match GHC.Tc.Gen.Pat@@ -665,6 +675,7 @@ GHC.Tc.Validity GHC.ThToHs GHC.Types.Name.Shape+ GHC.Types.Unique.SDFM GHC.Utils.Asm GHC.Utils.Monad.State GHCi.BinaryArray
− ghc-lib/stage0/compiler/build/GHC/Platform/Constants.hs
@@ -1,135 +0,0 @@-module GHC.Platform.Constants where--import Prelude--data PlatformConstants = PlatformConstants {- pc_CONTROL_GROUP_CONST_291 :: Int,- pc_STD_HDR_SIZE :: Int,- pc_PROF_HDR_SIZE :: Int,- pc_BLOCK_SIZE :: Int,- pc_BLOCKS_PER_MBLOCK :: Int,- pc_TICKY_BIN_COUNT :: Int,- pc_OFFSET_StgRegTable_rR1 :: Int,- pc_OFFSET_StgRegTable_rR2 :: Int,- pc_OFFSET_StgRegTable_rR3 :: Int,- pc_OFFSET_StgRegTable_rR4 :: Int,- pc_OFFSET_StgRegTable_rR5 :: Int,- pc_OFFSET_StgRegTable_rR6 :: Int,- pc_OFFSET_StgRegTable_rR7 :: Int,- pc_OFFSET_StgRegTable_rR8 :: Int,- pc_OFFSET_StgRegTable_rR9 :: Int,- pc_OFFSET_StgRegTable_rR10 :: Int,- pc_OFFSET_StgRegTable_rF1 :: Int,- pc_OFFSET_StgRegTable_rF2 :: Int,- pc_OFFSET_StgRegTable_rF3 :: Int,- pc_OFFSET_StgRegTable_rF4 :: Int,- pc_OFFSET_StgRegTable_rF5 :: Int,- pc_OFFSET_StgRegTable_rF6 :: Int,- pc_OFFSET_StgRegTable_rD1 :: Int,- pc_OFFSET_StgRegTable_rD2 :: Int,- pc_OFFSET_StgRegTable_rD3 :: Int,- pc_OFFSET_StgRegTable_rD4 :: Int,- pc_OFFSET_StgRegTable_rD5 :: Int,- pc_OFFSET_StgRegTable_rD6 :: Int,- pc_OFFSET_StgRegTable_rXMM1 :: Int,- pc_OFFSET_StgRegTable_rXMM2 :: Int,- pc_OFFSET_StgRegTable_rXMM3 :: Int,- pc_OFFSET_StgRegTable_rXMM4 :: Int,- pc_OFFSET_StgRegTable_rXMM5 :: Int,- pc_OFFSET_StgRegTable_rXMM6 :: Int,- pc_OFFSET_StgRegTable_rYMM1 :: Int,- pc_OFFSET_StgRegTable_rYMM2 :: Int,- pc_OFFSET_StgRegTable_rYMM3 :: Int,- pc_OFFSET_StgRegTable_rYMM4 :: Int,- pc_OFFSET_StgRegTable_rYMM5 :: Int,- pc_OFFSET_StgRegTable_rYMM6 :: Int,- pc_OFFSET_StgRegTable_rZMM1 :: Int,- pc_OFFSET_StgRegTable_rZMM2 :: Int,- pc_OFFSET_StgRegTable_rZMM3 :: Int,- pc_OFFSET_StgRegTable_rZMM4 :: Int,- pc_OFFSET_StgRegTable_rZMM5 :: Int,- pc_OFFSET_StgRegTable_rZMM6 :: Int,- pc_OFFSET_StgRegTable_rL1 :: Int,- pc_OFFSET_StgRegTable_rSp :: Int,- pc_OFFSET_StgRegTable_rSpLim :: Int,- pc_OFFSET_StgRegTable_rHp :: Int,- pc_OFFSET_StgRegTable_rHpLim :: Int,- pc_OFFSET_StgRegTable_rCCCS :: Int,- pc_OFFSET_StgRegTable_rCurrentTSO :: Int,- pc_OFFSET_StgRegTable_rCurrentNursery :: Int,- pc_OFFSET_StgRegTable_rHpAlloc :: Int,- pc_OFFSET_stgEagerBlackholeInfo :: Int,- pc_OFFSET_stgGCEnter1 :: Int,- pc_OFFSET_stgGCFun :: Int,- pc_OFFSET_Capability_r :: Int,- pc_OFFSET_bdescr_start :: Int,- pc_OFFSET_bdescr_free :: Int,- pc_OFFSET_bdescr_blocks :: Int,- pc_OFFSET_bdescr_flags :: Int,- pc_SIZEOF_CostCentreStack :: Int,- pc_OFFSET_CostCentreStack_mem_alloc :: Int,- pc_REP_CostCentreStack_mem_alloc :: Int,- pc_OFFSET_CostCentreStack_scc_count :: Int,- pc_REP_CostCentreStack_scc_count :: Int,- pc_OFFSET_StgHeader_ccs :: Int,- pc_OFFSET_StgHeader_ldvw :: Int,- pc_SIZEOF_StgSMPThunkHeader :: Int,- pc_OFFSET_StgEntCounter_allocs :: Int,- pc_REP_StgEntCounter_allocs :: Int,- pc_OFFSET_StgEntCounter_allocd :: Int,- pc_REP_StgEntCounter_allocd :: Int,- pc_OFFSET_StgEntCounter_registeredp :: Int,- pc_OFFSET_StgEntCounter_link :: Int,- pc_OFFSET_StgEntCounter_entry_count :: Int,- pc_SIZEOF_StgUpdateFrame_NoHdr :: Int,- pc_SIZEOF_StgMutArrPtrs_NoHdr :: Int,- pc_OFFSET_StgMutArrPtrs_ptrs :: Int,- pc_OFFSET_StgMutArrPtrs_size :: Int,- pc_SIZEOF_StgSmallMutArrPtrs_NoHdr :: Int,- pc_OFFSET_StgSmallMutArrPtrs_ptrs :: Int,- pc_SIZEOF_StgArrBytes_NoHdr :: Int,- pc_OFFSET_StgArrBytes_bytes :: Int,- pc_OFFSET_StgTSO_alloc_limit :: Int,- pc_OFFSET_StgTSO_cccs :: Int,- pc_OFFSET_StgTSO_stackobj :: Int,- pc_OFFSET_StgStack_sp :: Int,- pc_OFFSET_StgStack_stack :: Int,- pc_OFFSET_StgUpdateFrame_updatee :: Int,- pc_OFFSET_StgFunInfoExtraFwd_arity :: Int,- pc_REP_StgFunInfoExtraFwd_arity :: Int,- pc_SIZEOF_StgFunInfoExtraRev :: Int,- pc_OFFSET_StgFunInfoExtraRev_arity :: Int,- pc_REP_StgFunInfoExtraRev_arity :: Int,- pc_MAX_SPEC_SELECTEE_SIZE :: Int,- pc_MAX_SPEC_AP_SIZE :: Int,- pc_MIN_PAYLOAD_SIZE :: Int,- pc_MIN_INTLIKE :: Int,- pc_MAX_INTLIKE :: Int,- pc_MIN_CHARLIKE :: Int,- pc_MAX_CHARLIKE :: Int,- pc_MUT_ARR_PTRS_CARD_BITS :: Int,- pc_MAX_Vanilla_REG :: Int,- pc_MAX_Float_REG :: Int,- pc_MAX_Double_REG :: Int,- pc_MAX_Long_REG :: Int,- pc_MAX_XMM_REG :: Int,- pc_MAX_Real_Vanilla_REG :: Int,- pc_MAX_Real_Float_REG :: Int,- pc_MAX_Real_Double_REG :: Int,- pc_MAX_Real_XMM_REG :: Int,- pc_MAX_Real_Long_REG :: Int,- pc_RESERVED_C_STACK_BYTES :: Int,- pc_RESERVED_STACK_WORDS :: Int,- pc_AP_STACK_SPLIM :: Int,- pc_WORD_SIZE :: Int,- pc_CINT_SIZE :: Int,- pc_CLONG_SIZE :: Int,- pc_CLONG_LONG_SIZE :: Int,- pc_BITMAP_BITS_SHIFT :: Int,- pc_TAG_BITS :: Int,- pc_DYNAMIC_BY_DEFAULT :: Bool,- pc_LDV_SHIFT :: Int,- pc_ILDV_CREATE_MASK :: Integer,- pc_ILDV_STATE_CREATE :: Integer,- pc_ILDV_STATE_USE :: Integer- } deriving (Show,Read,Eq)
ghc-lib/stage0/compiler/build/primop-code-size.hs-incl view
@@ -2,11 +2,11 @@ primOpCodeSize IntAddCOp = 2 primOpCodeSize IntSubCOp = 2 primOpCodeSize ChrOp = 0-primOpCodeSize Int2WordOp = 0+primOpCodeSize IntToWordOp = 0 primOpCodeSize WordAddCOp = 2 primOpCodeSize WordSubCOp = 2 primOpCodeSize WordAdd2Op = 2-primOpCodeSize Word2IntOp = 0+primOpCodeSize WordToIntOp = 0 primOpCodeSize DoubleExpOp = primOpCodeSizeForeignCall primOpCodeSize DoubleExpM1Op = primOpCodeSizeForeignCall primOpCodeSize DoubleLogOp = primOpCodeSizeForeignCall @@ -50,8 +50,8 @@ primOpCodeSize CopyMutableByteArrayToAddrOp = primOpCodeSizeForeignCall + 4 primOpCodeSize CopyAddrToByteArrayOp = primOpCodeSizeForeignCall + 4 primOpCodeSize SetByteArrayOp = primOpCodeSizeForeignCall + 4 -primOpCodeSize Addr2IntOp = 0-primOpCodeSize Int2AddrOp = 0+primOpCodeSize AddrToIntOp = 0+primOpCodeSize IntToAddrOp = 0 primOpCodeSize WriteMutVarOp = primOpCodeSizeForeignCall primOpCodeSize TouchOp = 0 primOpCodeSize ParOp = primOpCodeSizeForeignCall
ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl view
@@ -88,11 +88,11 @@ | IntLtOp | IntLeOp | ChrOp- | Int2WordOp- | Int2FloatOp- | Int2DoubleOp- | Word2FloatOp- | Word2DoubleOp+ | IntToWordOp+ | IntToFloatOp+ | IntToDoubleOp+ | WordToFloatOp+ | WordToDoubleOp | ISllOp | ISraOp | ISrlOp@@ -113,7 +113,7 @@ | NotOp | SllOp | SrlOp- | Word2IntOp+ | WordToIntOp | WordGtOp | WordGeOp | WordEqOp@@ -172,8 +172,8 @@ | DoubleDivOp | DoubleNegOp | DoubleFabsOp- | Double2IntOp- | Double2FloatOp+ | DoubleToIntOp+ | DoubleToFloatOp | DoubleExpOp | DoubleExpM1Op | DoubleLogOp@@ -206,7 +206,7 @@ | FloatDivOp | FloatNegOp | FloatFabsOp- | Float2IntOp+ | FloatToIntOp | FloatExpOp | FloatExpM1Op | FloatLogOp@@ -225,7 +225,7 @@ | FloatAcoshOp | FloatAtanhOp | FloatPowerOp- | Float2DoubleOp+ | FloatToDoubleOp | FloatDecode_IntOp | NewArrayOp | SameMutableArrayOp@@ -400,8 +400,8 @@ | AddrAddOp | AddrSubOp | AddrRemOp- | Addr2IntOp- | Int2AddrOp+ | AddrToIntOp+ | IntToAddrOp | AddrGtOp | AddrGeOp | AddrEqOp
ghc-lib/stage0/compiler/build/primop-list.hs-incl view
@@ -87,11 +87,11 @@ , IntLtOp , IntLeOp , ChrOp- , Int2WordOp- , Int2FloatOp- , Int2DoubleOp- , Word2FloatOp- , Word2DoubleOp+ , IntToWordOp+ , IntToFloatOp+ , IntToDoubleOp+ , WordToFloatOp+ , WordToDoubleOp , ISllOp , ISraOp , ISrlOp@@ -112,7 +112,7 @@ , NotOp , SllOp , SrlOp- , Word2IntOp+ , WordToIntOp , WordGtOp , WordGeOp , WordEqOp@@ -171,8 +171,8 @@ , DoubleDivOp , DoubleNegOp , DoubleFabsOp- , Double2IntOp- , Double2FloatOp+ , DoubleToIntOp+ , DoubleToFloatOp , DoubleExpOp , DoubleExpM1Op , DoubleLogOp@@ -205,7 +205,7 @@ , FloatDivOp , FloatNegOp , FloatFabsOp- , Float2IntOp+ , FloatToIntOp , FloatExpOp , FloatExpM1Op , FloatLogOp@@ -224,7 +224,7 @@ , FloatAcoshOp , FloatAtanhOp , FloatPowerOp- , Float2DoubleOp+ , FloatToDoubleOp , FloatDecode_IntOp , NewArrayOp , SameMutableArrayOp@@ -399,8 +399,8 @@ , AddrAddOp , AddrSubOp , AddrRemOp- , Addr2IntOp- , Int2AddrOp+ , AddrToIntOp+ , IntToAddrOp , AddrGtOp , AddrGeOp , AddrEqOp
ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl view
@@ -87,11 +87,11 @@ primOpInfo IntLtOp = mkCompare (fsLit "<#") intPrimTy primOpInfo IntLeOp = mkCompare (fsLit "<=#") intPrimTy primOpInfo ChrOp = mkGenPrimOp (fsLit "chr#") [] [intPrimTy] (charPrimTy)-primOpInfo Int2WordOp = mkGenPrimOp (fsLit "int2Word#") [] [intPrimTy] (wordPrimTy)-primOpInfo Int2FloatOp = mkGenPrimOp (fsLit "int2Float#") [] [intPrimTy] (floatPrimTy)-primOpInfo Int2DoubleOp = mkGenPrimOp (fsLit "int2Double#") [] [intPrimTy] (doublePrimTy)-primOpInfo Word2FloatOp = mkGenPrimOp (fsLit "word2Float#") [] [wordPrimTy] (floatPrimTy)-primOpInfo Word2DoubleOp = mkGenPrimOp (fsLit "word2Double#") [] [wordPrimTy] (doublePrimTy)+primOpInfo IntToWordOp = mkGenPrimOp (fsLit "int2Word#") [] [intPrimTy] (wordPrimTy)+primOpInfo IntToFloatOp = mkGenPrimOp (fsLit "int2Float#") [] [intPrimTy] (floatPrimTy)+primOpInfo IntToDoubleOp = mkGenPrimOp (fsLit "int2Double#") [] [intPrimTy] (doublePrimTy)+primOpInfo WordToFloatOp = mkGenPrimOp (fsLit "word2Float#") [] [wordPrimTy] (floatPrimTy)+primOpInfo WordToDoubleOp = mkGenPrimOp (fsLit "word2Double#") [] [wordPrimTy] (doublePrimTy) primOpInfo ISllOp = mkGenPrimOp (fsLit "uncheckedIShiftL#") [] [intPrimTy, intPrimTy] (intPrimTy) primOpInfo ISraOp = mkGenPrimOp (fsLit "uncheckedIShiftRA#") [] [intPrimTy, intPrimTy] (intPrimTy) primOpInfo ISrlOp = mkGenPrimOp (fsLit "uncheckedIShiftRL#") [] [intPrimTy, intPrimTy] (intPrimTy)@@ -112,7 +112,7 @@ primOpInfo NotOp = mkGenPrimOp (fsLit "not#") [] [wordPrimTy] (wordPrimTy) primOpInfo SllOp = mkGenPrimOp (fsLit "uncheckedShiftL#") [] [wordPrimTy, intPrimTy] (wordPrimTy) primOpInfo SrlOp = mkGenPrimOp (fsLit "uncheckedShiftRL#") [] [wordPrimTy, intPrimTy] (wordPrimTy)-primOpInfo Word2IntOp = mkGenPrimOp (fsLit "word2Int#") [] [wordPrimTy] (intPrimTy)+primOpInfo WordToIntOp = mkGenPrimOp (fsLit "word2Int#") [] [wordPrimTy] (intPrimTy) primOpInfo WordGtOp = mkCompare (fsLit "gtWord#") wordPrimTy primOpInfo WordGeOp = mkCompare (fsLit "geWord#") wordPrimTy primOpInfo WordEqOp = mkCompare (fsLit "eqWord#") wordPrimTy@@ -171,8 +171,8 @@ primOpInfo DoubleDivOp = mkGenPrimOp (fsLit "/##") [] [doublePrimTy, doublePrimTy] (doublePrimTy) primOpInfo DoubleNegOp = mkGenPrimOp (fsLit "negateDouble#") [] [doublePrimTy] (doublePrimTy) primOpInfo DoubleFabsOp = mkGenPrimOp (fsLit "fabsDouble#") [] [doublePrimTy] (doublePrimTy)-primOpInfo Double2IntOp = mkGenPrimOp (fsLit "double2Int#") [] [doublePrimTy] (intPrimTy)-primOpInfo Double2FloatOp = mkGenPrimOp (fsLit "double2Float#") [] [doublePrimTy] (floatPrimTy)+primOpInfo DoubleToIntOp = mkGenPrimOp (fsLit "double2Int#") [] [doublePrimTy] (intPrimTy)+primOpInfo DoubleToFloatOp = mkGenPrimOp (fsLit "double2Float#") [] [doublePrimTy] (floatPrimTy) primOpInfo DoubleExpOp = mkGenPrimOp (fsLit "expDouble#") [] [doublePrimTy] (doublePrimTy) primOpInfo DoubleExpM1Op = mkGenPrimOp (fsLit "expm1Double#") [] [doublePrimTy] (doublePrimTy) primOpInfo DoubleLogOp = mkGenPrimOp (fsLit "logDouble#") [] [doublePrimTy] (doublePrimTy)@@ -205,7 +205,7 @@ primOpInfo FloatDivOp = mkGenPrimOp (fsLit "divideFloat#") [] [floatPrimTy, floatPrimTy] (floatPrimTy) primOpInfo FloatNegOp = mkGenPrimOp (fsLit "negateFloat#") [] [floatPrimTy] (floatPrimTy) primOpInfo FloatFabsOp = mkGenPrimOp (fsLit "fabsFloat#") [] [floatPrimTy] (floatPrimTy)-primOpInfo Float2IntOp = mkGenPrimOp (fsLit "float2Int#") [] [floatPrimTy] (intPrimTy)+primOpInfo FloatToIntOp = mkGenPrimOp (fsLit "float2Int#") [] [floatPrimTy] (intPrimTy) primOpInfo FloatExpOp = mkGenPrimOp (fsLit "expFloat#") [] [floatPrimTy] (floatPrimTy) primOpInfo FloatExpM1Op = mkGenPrimOp (fsLit "expm1Float#") [] [floatPrimTy] (floatPrimTy) primOpInfo FloatLogOp = mkGenPrimOp (fsLit "logFloat#") [] [floatPrimTy] (floatPrimTy)@@ -224,7 +224,7 @@ primOpInfo FloatAcoshOp = mkGenPrimOp (fsLit "acoshFloat#") [] [floatPrimTy] (floatPrimTy) primOpInfo FloatAtanhOp = mkGenPrimOp (fsLit "atanhFloat#") [] [floatPrimTy] (floatPrimTy) primOpInfo FloatPowerOp = mkGenPrimOp (fsLit "powerFloat#") [] [floatPrimTy, floatPrimTy] (floatPrimTy)-primOpInfo Float2DoubleOp = mkGenPrimOp (fsLit "float2Double#") [] [floatPrimTy] (doublePrimTy)+primOpInfo FloatToDoubleOp = mkGenPrimOp (fsLit "float2Double#") [] [floatPrimTy] (doublePrimTy) primOpInfo FloatDecode_IntOp = mkGenPrimOp (fsLit "decodeFloat_Int#") [] [floatPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy])) primOpInfo NewArrayOp = mkGenPrimOp (fsLit "newArray#") [alphaTyVar, deltaTyVar] [intPrimTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy])) primOpInfo SameMutableArrayOp = mkGenPrimOp (fsLit "sameMutableArray#") [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, mkMutableArrayPrimTy deltaTy alphaTy] (intPrimTy)@@ -399,8 +399,8 @@ primOpInfo AddrAddOp = mkGenPrimOp (fsLit "plusAddr#") [] [addrPrimTy, intPrimTy] (addrPrimTy) primOpInfo AddrSubOp = mkGenPrimOp (fsLit "minusAddr#") [] [addrPrimTy, addrPrimTy] (intPrimTy) primOpInfo AddrRemOp = mkGenPrimOp (fsLit "remAddr#") [] [addrPrimTy, intPrimTy] (intPrimTy)-primOpInfo Addr2IntOp = mkGenPrimOp (fsLit "addr2Int#") [] [addrPrimTy] (intPrimTy)-primOpInfo Int2AddrOp = mkGenPrimOp (fsLit "int2Addr#") [] [intPrimTy] (addrPrimTy)+primOpInfo AddrToIntOp = mkGenPrimOp (fsLit "addr2Int#") [] [addrPrimTy] (intPrimTy)+primOpInfo IntToAddrOp = mkGenPrimOp (fsLit "int2Addr#") [] [intPrimTy] (addrPrimTy) primOpInfo AddrGtOp = mkCompare (fsLit "gtAddr#") addrPrimTy primOpInfo AddrGeOp = mkCompare (fsLit "geAddr#") addrPrimTy primOpInfo AddrEqOp = mkCompare (fsLit "eqAddr#") addrPrimTy
ghc-lib/stage0/compiler/build/primop-tag.hs-incl view
@@ -90,11 +90,11 @@ primOpTag IntLtOp = 87 primOpTag IntLeOp = 88 primOpTag ChrOp = 89-primOpTag Int2WordOp = 90-primOpTag Int2FloatOp = 91-primOpTag Int2DoubleOp = 92-primOpTag Word2FloatOp = 93-primOpTag Word2DoubleOp = 94+primOpTag IntToWordOp = 90+primOpTag IntToFloatOp = 91+primOpTag IntToDoubleOp = 92+primOpTag WordToFloatOp = 93+primOpTag WordToDoubleOp = 94 primOpTag ISllOp = 95 primOpTag ISraOp = 96 primOpTag ISrlOp = 97@@ -115,7 +115,7 @@ primOpTag NotOp = 112 primOpTag SllOp = 113 primOpTag SrlOp = 114-primOpTag Word2IntOp = 115+primOpTag WordToIntOp = 115 primOpTag WordGtOp = 116 primOpTag WordGeOp = 117 primOpTag WordEqOp = 118@@ -174,8 +174,8 @@ primOpTag DoubleDivOp = 171 primOpTag DoubleNegOp = 172 primOpTag DoubleFabsOp = 173-primOpTag Double2IntOp = 174-primOpTag Double2FloatOp = 175+primOpTag DoubleToIntOp = 174+primOpTag DoubleToFloatOp = 175 primOpTag DoubleExpOp = 176 primOpTag DoubleExpM1Op = 177 primOpTag DoubleLogOp = 178@@ -208,7 +208,7 @@ primOpTag FloatDivOp = 205 primOpTag FloatNegOp = 206 primOpTag FloatFabsOp = 207-primOpTag Float2IntOp = 208+primOpTag FloatToIntOp = 208 primOpTag FloatExpOp = 209 primOpTag FloatExpM1Op = 210 primOpTag FloatLogOp = 211@@ -227,7 +227,7 @@ primOpTag FloatAcoshOp = 224 primOpTag FloatAtanhOp = 225 primOpTag FloatPowerOp = 226-primOpTag Float2DoubleOp = 227+primOpTag FloatToDoubleOp = 227 primOpTag FloatDecode_IntOp = 228 primOpTag NewArrayOp = 229 primOpTag SameMutableArrayOp = 230@@ -402,8 +402,8 @@ primOpTag AddrAddOp = 399 primOpTag AddrSubOp = 400 primOpTag AddrRemOp = 401-primOpTag Addr2IntOp = 402-primOpTag Int2AddrOp = 403+primOpTag AddrToIntOp = 402+primOpTag IntToAddrOp = 403 primOpTag AddrGtOp = 404 primOpTag AddrGeOp = 405 primOpTag AddrEqOp = 406
ghc-lib/stage0/lib/ghcversion.h view
@@ -2,14 +2,14 @@ #define __GHCVERSION_H__ #if !defined(__GLASGOW_HASKELL__)-#define __GLASGOW_HASKELL__ 811+#define __GLASGOW_HASKELL__ 901 #endif #if !defined(__GLASGOW_HASKELL_FULL_VERSION__)-#define __GLASGOW_HASKELL_FULL_VERSION__ "8.11.0.20200901"+#define __GLASGOW_HASKELL_FULL_VERSION__ "9.1.0.20201001" #endif #define __GLASGOW_HASKELL_PATCHLEVEL1__ 0-#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20200901+#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20201001 #define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\ ((ma)*100+(mi)) < __GLASGOW_HASKELL__ || \
ghc-lib/stage0/lib/settings view
@@ -18,6 +18,8 @@ ,("ar flags", "qcls") ,("ar supports at file", "NO") ,("ranlib command", "ranlib")+,("otool command", "otool")+,("install_name_tool command", "install_name_tool") ,("touch command", "touch") ,("dllwrap command", "/bin/false") ,("windres command", "/bin/false")